adding redex to main SVN archive so it goes into the distribution
svn: r10974
This commit is contained in:
Robby Findler
parent
8d0d6d5d28
commit
341d0c76a9
417
collects/redex/HISTORY
Normal file
417
collects/redex/HISTORY
Normal file
|
|
@ -0,0 +1,417 @@
|
|||
("robby" "redex.plt" 5 0)
|
||||
|
||||
EXTENSIONS:
|
||||
|
||||
- added test-equal, test-pred, test-reduces, and test-results
|
||||
|
||||
- removed restriction on apply-reduction-relation*
|
||||
replaced it with additional work while matching
|
||||
non-terminals to remove the redundancy
|
||||
|
||||
- added `in-domain?'
|
||||
|
||||
CHANGES:
|
||||
|
||||
- zero occurrences of a hole when matching an `in-hole' now
|
||||
correctly fails.
|
||||
|
||||
- the `where' keyword in reduction-relation became `with' (and the
|
||||
arguments reversed order)
|
||||
|
||||
- renamed the `rib' struct to `bind' (and mismatch-rib =>
|
||||
mismatch-bind)
|
||||
|
||||
- merged the various traces functions into a single
|
||||
function that accepts keyword arguments.
|
||||
|
||||
- renamed the loc-wrapper struct to lw.
|
||||
|
||||
- language->ps and language->pict's listof-symbols is now
|
||||
optional and thus the language->ps's arguments changed
|
||||
order to make that work.
|
||||
|
||||
- renamed test-match to redex-match
|
||||
|
||||
- no long export mtch struct or bindings struct and
|
||||
test-match's result is not simplified.
|
||||
|
||||
- extend-reduction-relation now uses the names of the
|
||||
rules to replace existing rules (instead of just
|
||||
unioning the rules)
|
||||
|
||||
- in-hole used to substitute into named holes, but now it
|
||||
only substitutes into unnamed holes. Use in-named-hole
|
||||
on the right-hand side to do the substitution
|
||||
|
||||
- removed hole-here
|
||||
|
||||
BUG FIXES:
|
||||
|
||||
- fixed a (not easily noticed) bug in the way hole
|
||||
matching worked for named holes.
|
||||
|
||||
- extending a non-terminal that's been defined together
|
||||
with other non-terminals now works as expected.
|
||||
|
||||
- handling of non-terminals uses that have underscores in
|
||||
them now works properly (only showed up when using them
|
||||
in the definition of a langauge)
|
||||
|
||||
- an extended language can now define multiple non-terminals
|
||||
together
|
||||
|
||||
("robby" "redex.plt" 4 4)
|
||||
|
||||
- undid some changes that broke backwards compatibility
|
||||
|
||||
("robby" "redex.plt" 4 3)
|
||||
|
||||
- added extend-reduction-relation
|
||||
- fixed a bug whereby reduction relations that reduced to
|
||||
false were always ignored
|
||||
|
||||
("robby" "redex.plt" 4 2)
|
||||
|
||||
- fixed a bug in the way `in-hole' inside
|
||||
an ellipsis on the right-hand side of a
|
||||
reduction rule.
|
||||
|
||||
("robby" "redex.plt" 4 1)
|
||||
|
||||
- improved stepper so that scrolling works when large
|
||||
terms are present.
|
||||
|
||||
("robby" "redex.plt" 4 0)
|
||||
|
||||
- changed conventions for subscripts. Now, non-terminals
|
||||
w/out subscripts bind in reduction rules (but they still
|
||||
do not bind in grammar definitions).
|
||||
|
||||
- wheres and side-conditions now bind as expected in
|
||||
reduction-rules
|
||||
|
||||
- fixed a bug in metafunction pict generation (parallel
|
||||
fix from 3.28)
|
||||
|
||||
- renamed horizontal-arrow-space to arrow-space.
|
||||
- renamed horizontal-label-space to label-space.
|
||||
|
||||
("robby" "redex.plt" 3 27)
|
||||
|
||||
- added horizontal-arrow-space, horizontal-label-space
|
||||
- number & variable now typeset in italics (to match the other non-terminals)
|
||||
- improved fresh variable generation
|
||||
- added `where' for bindings in metafunctions
|
||||
- added 'up-down mode for metafunction typesetting
|
||||
- added optional argument to reduction-relation->pict &
|
||||
reduction-relation->ps
|
||||
- PR 8957
|
||||
|
||||
("robby" "redex.plt" 3 26)
|
||||
|
||||
- fixed a bug in pict generation
|
||||
|
||||
("robby" "redex.plt" 3 25)
|
||||
|
||||
- added hole-here support for `term'
|
||||
|
||||
("robby" "redex.plt" 3 24)
|
||||
|
||||
- added curly-quotes-for-strings and current-text
|
||||
|
||||
("robby" "redex.plt" 3 23)
|
||||
|
||||
- fixed a bug that cause typesetting of grammars that
|
||||
defined hole as the first production of some
|
||||
non-terminal.
|
||||
|
||||
- added hide-hole pattern
|
||||
|
||||
("robby" "redex.plt" 3 22)
|
||||
|
||||
- ??
|
||||
|
||||
("robby" "redex.plt" 3 21)
|
||||
|
||||
- added `where' as a binding form in the individual
|
||||
clauses of a reduction-relation.
|
||||
|
||||
- typesetting:
|
||||
|
||||
- improved handling of nested term, quote,
|
||||
unquote, and unquote-splicing.
|
||||
|
||||
- fixed up in-named-hole and (hole x) to use subscripts.
|
||||
|
||||
- improved the docs for the loc wrappers to explain
|
||||
logical spacing.
|
||||
|
||||
- improved typesetting of languages built with
|
||||
extend-language. See extend-language-show-union.
|
||||
|
||||
- added set-arrow-pict!
|
||||
|
||||
("robby" "redex.plt" 3 20)
|
||||
|
||||
- improved the interface for rewriting aspects of the typesetting.
|
||||
|
||||
- added linebreaks, with-compound-rewriter, and with-atomic-rewriter
|
||||
|
||||
("robby" "redex.plt" 3 19)
|
||||
|
||||
- improved source locations for error messages when misusing ellipses, eg:
|
||||
(term-let ([(x ...) '(1 2)] [(y ...) '(1 2 3)]) (term ((x y) ...)))
|
||||
or similar things via reduction-relation, metafunctions, etc.
|
||||
|
||||
- fixed PR 8752: `name' patterns only show the name,
|
||||
leaving the thing defined to the where clause
|
||||
|
||||
("robby" "redex.plt" 3 18)
|
||||
|
||||
- fixed PRS relating to pict generation: 8749 8751 8750
|
||||
and a few other bugs along the way.
|
||||
|
||||
("robby" "redex.plt" 3 17)
|
||||
|
||||
- initial-char-width now controls both the stepper & traces
|
||||
|
||||
("robby" "redex.plt" 3 16)
|
||||
|
||||
- added define-multi-args-metafunction
|
||||
- finished first pass of the pict generation rewriting
|
||||
|
||||
("robby" "redex.plt" 3 15)
|
||||
|
||||
- fixed a bug in stepper/seed
|
||||
|
||||
("robby" "redex.plt" 3 14)
|
||||
|
||||
- fixed some silly mistakes in the packaging
|
||||
|
||||
("robby" "redex.plt" 3 13)
|
||||
|
||||
- added variable-not-otherwise-mentioned as a new pattern
|
||||
- added stepper/seed
|
||||
- added an optional pretty-printing argument to stepper.
|
||||
- improved the ps rendering of the arrows
|
||||
for --> -> => ==> ~> and ~~>
|
||||
- rewrote internals of pict rendering (hopefully no change
|
||||
yet, but there may be bugs introduced ...).
|
||||
|
||||
("robby" "redex.plt" 3 12)
|
||||
|
||||
- Added pict and .ps generation functions for
|
||||
reduction-relations, metafunctions, and grammars. These
|
||||
are still primitive; the most obvious missing feature is
|
||||
the inability (without secret knowledge) to replace the
|
||||
pink stuff.
|
||||
- fixed a bug in the way the stepper highlights
|
||||
differences in the presence of quote (by disabling the '
|
||||
shortcuts printing)
|
||||
|
||||
NOTE this version of redex requires not just any
|
||||
369.100, but one from 5/19 in the afternoon (or newer).
|
||||
|
||||
("robby" "redex.plt" 3 11)
|
||||
|
||||
- changed the order of the arguments in the new `fresh' clauses
|
||||
introduced in the last release.
|
||||
|
||||
("robby" "redex.plt" 3 10)
|
||||
|
||||
- fixed bugs in the way that ..._x patterns work (they
|
||||
didn't handle binding well).
|
||||
- fixed misc bugs in the stepper
|
||||
- added the ability to generate a sequence of fresh variables
|
||||
in a single rule
|
||||
|
||||
("robby" "redex.plt" 3 9)
|
||||
|
||||
- added side-condition specs to metafunctions
|
||||
- added test-reduces and test-reduces/multiple to schemeunit.ss
|
||||
- fixed a bug in the handling of _!_
|
||||
- improved the "found the same binder" error message to show
|
||||
the source locations of the two offending binders
|
||||
|
||||
("robby" "redex.plt" 3 8)
|
||||
|
||||
- fixed a bug in the way (hole #f) patterns matched.
|
||||
- fixed a bug in the initial height of the boxes in `traces'
|
||||
- added reduction->relation-names
|
||||
- added ability to step until a particular reduction (and
|
||||
the reduction labels) in the stepper.
|
||||
|
||||
("robby" "redex.plt" 3 7)
|
||||
|
||||
- improved syntax error message (PR 8576)
|
||||
- added difference highlighting for adjacent terms in the stepper
|
||||
|
||||
("robby" "redex.plt" 3 6)
|
||||
|
||||
- added stepper
|
||||
|
||||
("robby" "redex.plt" 3 5)
|
||||
|
||||
- bugfix (I think ... this version's changes seem to have been forgotten)
|
||||
|
||||
("robby" "redex.plt" 3 4)
|
||||
|
||||
- added term-node-children
|
||||
|
||||
("robby" "redex.plt" 3 3)
|
||||
|
||||
- added term-match and term-match/single
|
||||
- added variables-not-in
|
||||
- fixed a bug in metafunctions
|
||||
|
||||
("robby" "redex.plt" 3 2)
|
||||
|
||||
- added language-nts
|
||||
- added better error messages when using parts of the
|
||||
pattern language as ordinary things in the grammar.
|
||||
|
||||
("robby" "redex.plt" 3 1)
|
||||
|
||||
- adds the ability to have multi-colored terms, not just
|
||||
pink ones.
|
||||
|
||||
("robby" "redex.plt" 3 0)
|
||||
|
||||
This release changes the syntax of the reduction relations
|
||||
to make it more consistent and more in line with the way
|
||||
reduction relations are written in papers. This is the
|
||||
precise set of removals and additions:
|
||||
|
||||
- added extend-language
|
||||
- added reduction-rule & apply-reduction-relation
|
||||
- added union-reduction-relations
|
||||
- added define-language
|
||||
|
||||
- changed compatible-closure & context-closure so that the
|
||||
pattern argument is not quoted, but is just the pattern
|
||||
in the last argument.
|
||||
|
||||
- changed term-node-labels so that it can return #f (in
|
||||
the list) when a reduction doesn't have a label.
|
||||
|
||||
- removed language->predicate, compile-pattern,
|
||||
match-pattern (use test-match instead)
|
||||
|
||||
- removed reduction, reduction/name, reduction/context,
|
||||
reduction/context/name (use reduction-relation instead)
|
||||
|
||||
- removed red? (use reduction-relation? instead)
|
||||
|
||||
- removed reduce (use apply-reduction-relation instead)
|
||||
|
||||
- removed reduce-all (use apply-reduction-relation* insetad)
|
||||
|
||||
- removed reduce/tag-with-reduction (use
|
||||
apply-reduction-relation/tag-with-names instead)
|
||||
|
||||
- removed red-name, reduction->name, give-name
|
||||
|
||||
- removed language (use define-language instead)
|
||||
|
||||
- removed helper.ss
|
||||
|
||||
Other improvements:
|
||||
|
||||
- check syntax draws arrows for the non-terminals in a
|
||||
`language' now, both to the language and to the
|
||||
reduction rules.
|
||||
|
||||
("robby" "redex.plt" 2 6)
|
||||
|
||||
- added reduce-all and note about bad parsing performance
|
||||
issues.
|
||||
|
||||
- added `test-match' and note about how to debug redex
|
||||
programs to doc.txt
|
||||
|
||||
- added redex-specific 'check' functions for use with
|
||||
schemeunit.
|
||||
|
||||
- add `metafunction' for defining meta functions using the
|
||||
pattern matching notation used in reductions and grammars.
|
||||
|
||||
("robby" "redex.plt" 2 5)
|
||||
|
||||
- fixed bugs in compatible-closure & context-closure
|
||||
|
||||
("robby" "redex.plt" 2 4)
|
||||
|
||||
- reduced the amount of memory used for caching
|
||||
significantly (with some small speedup for
|
||||
a largeish reduction semantics test suite)
|
||||
|
||||
- added set-cache-size!
|
||||
|
||||
- added variable-prefix pattern
|
||||
|
||||
- added ..._<id> pattern that can be used to ensure matching
|
||||
lengths of repeated patterns.
|
||||
|
||||
- added _!_ subscripts (both in ... and regular) to ensure
|
||||
that the matched things are different (or have different
|
||||
lengths in the case of ..._!_ subscripts)
|
||||
|
||||
("robby" "redex.plt" 2 3)
|
||||
|
||||
- added the ability to traverse the graph generated by
|
||||
traces in order to decide if a term should be
|
||||
highlighted in red. See the traces/pred documentation
|
||||
for details.
|
||||
|
||||
- added term-node functions
|
||||
|
||||
- added red-name function
|
||||
|
||||
- removed make-plt.ss from archive
|
||||
|
||||
("robby" "redex.plt" 2 2)
|
||||
|
||||
- added a blurb, fixed a typo in the docs.
|
||||
|
||||
("robby" "redex.plt" 2 1)
|
||||
|
||||
- changed the way a contract is specified on the matcher
|
||||
to get a 30% speed up on the beginner test suite.
|
||||
Thanks, Matthew for spotting that!
|
||||
|
||||
("robby" "redex.plt" 2 0)
|
||||
|
||||
- fixed a bug in compatible-closure handling that could
|
||||
result in duplicate matches when there should only have
|
||||
been a single match.
|
||||
|
||||
- added labels to edges for reductions
|
||||
when shown in GUI. See docs for
|
||||
reduction/name
|
||||
|
||||
- small performance improvement to matcher
|
||||
(10-20% on non-trivial examples)
|
||||
|
||||
- added letrec.ss example (and improved some
|
||||
of the examples to use labels)
|
||||
|
||||
("robby" "redex.plt" 1 3)
|
||||
|
||||
- Fixed a bug in the the compatible closure function; otherwise the
|
||||
same as 1.1
|
||||
|
||||
("robby" "redex.plt" 1 2)
|
||||
|
||||
- Obsolete'd version. It used to be a first attempt at the 2.0
|
||||
revision, but now should be avoided.
|
||||
|
||||
Use 2.0 instead of this version.
|
||||
|
||||
("robby" "redex.plt" 1 1)
|
||||
|
||||
- fixed packaging error
|
||||
|
||||
("robby" "redex.plt" 1 0)
|
||||
|
||||
- initial release to PLaneT
|
||||
|
||||
1679
collects/redex/doc.txt
Normal file
1679
collects/redex/doc.txt
Normal file
File diff suppressed because it is too large
Load Diff
42
collects/redex/examples/arithmetic.ss
Normal file
42
collects/redex/examples/arithmetic.ss
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
(module arithmetic mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(define-language lang
|
||||
(e (binop e e)
|
||||
(sqrt e)
|
||||
number)
|
||||
(binop +
|
||||
-
|
||||
*
|
||||
/)
|
||||
|
||||
(e-ctxt (binop e e-ctxt)
|
||||
(binop e-ctxt e)
|
||||
(sqrt e-ctxt)
|
||||
hole)
|
||||
(v number))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(c--> (+ number_1 number_2)
|
||||
,(+ (term number_1) (term number_2))
|
||||
"add")
|
||||
(c--> (- number_1 number_2)
|
||||
,(- (term number_1) (term number_2))
|
||||
"subtract")
|
||||
(c--> (* number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
"multiply")
|
||||
(c--> (/ number_1 number_2)
|
||||
,(/ (term number_1) (term number_2))
|
||||
"divide")
|
||||
(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)]))
|
||||
|
||||
(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2)))))
|
||||
931
collects/redex/examples/beginner.ss
Normal file
931
collects/redex/examples/beginner.ss
Normal file
|
|
@ -0,0 +1,931 @@
|
|||
#|
|
||||
|
||||
This is the semantics of Beginner Scheme, one of the
|
||||
languages in DrScheme.
|
||||
|
||||
The first test case fails because the beginner spec
|
||||
is broken for that program (ie, the model faithfully
|
||||
reflects the (broken) spec).
|
||||
|
||||
|#
|
||||
|
||||
(module beginner mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "match.ss"))
|
||||
|
||||
(provide run-tests
|
||||
run-big-test)
|
||||
|
||||
#|
|
||||
|
||||
`lang' below is actually more generous than beginner, but the
|
||||
reductions assume that the programs are all syntactically
|
||||
well-formed programs in beginner scheme (with the additional
|
||||
constraints that all makers are properly applied and function-
|
||||
defined variables are only applied and non-function-defined
|
||||
variables are never applied -- except for the maker check,
|
||||
these will be in a future version of beginner)
|
||||
|
||||
still missing: many primops and characters
|
||||
|
||||
are there any primops that take zero arguments?
|
||||
(should that be syntacically disallowed?)
|
||||
|
||||
|#
|
||||
|
||||
(define-language lang
|
||||
(p (d/e ...))
|
||||
(d/e (define (x x x ...) e)
|
||||
(define x (lambda (x x ...) e))
|
||||
(define x e)
|
||||
(define-struct x (x ...))
|
||||
e)
|
||||
(e (x e e ...)
|
||||
(prim-op e ...)
|
||||
(cond (e e) (e e) ...)
|
||||
(cond (e e) ... (else e))
|
||||
(if e e e)
|
||||
(and e e e ...)
|
||||
(or e e e ...)
|
||||
empty
|
||||
x
|
||||
'x
|
||||
number
|
||||
boolean
|
||||
string)
|
||||
|
||||
(prim-op + / cons first rest empty? struct? symbol=?)
|
||||
|
||||
(p-ctxt (d/e-v ... d/e-ctxt d/e ...))
|
||||
(d/e-ctxt (define x e-ctxt)
|
||||
e-ctxt)
|
||||
(e-ctxt hole
|
||||
(x v ... e-ctxt e ...)
|
||||
(prim-op v ... e-ctxt e ...)
|
||||
(cond [false e] ... [e-ctxt e] [e e] ...)
|
||||
(cond [false e] ... [e-ctxt e] [e e] ... [else e])
|
||||
(and true ... e-ctxt e ...)
|
||||
(or false ... e-ctxt e ...))
|
||||
|
||||
(d/e-v (define x (lambda (x x ...) e))
|
||||
(define x v)
|
||||
(define (x x x ...) e)
|
||||
(define-struct x (x ...))
|
||||
v)
|
||||
|
||||
(v (maker v ...)
|
||||
non-struct-value)
|
||||
(non-struct-value number
|
||||
list-value
|
||||
boolean
|
||||
string
|
||||
'x)
|
||||
(list-value empty
|
||||
(cons v list-value))
|
||||
(boolean true
|
||||
false)
|
||||
|
||||
(maker (side-condition variable_1 (maker? (term variable_1))))
|
||||
|
||||
(x (side-condition
|
||||
(name
|
||||
x
|
||||
(variable-except define
|
||||
define-struct
|
||||
lambda
|
||||
cond
|
||||
else
|
||||
if
|
||||
and
|
||||
or
|
||||
empty
|
||||
true
|
||||
false
|
||||
quote))
|
||||
(not (prim-op? (term x))))))
|
||||
|
||||
(define beg-e-subst
|
||||
(subst
|
||||
[(? number?)
|
||||
(constant)]
|
||||
[(? symbol?)
|
||||
(variable)]
|
||||
;; slight cheat here -- but since cond, if, and, or, etc
|
||||
;; aren't allowed to be variables (syntactically), we're okay.
|
||||
[`(,@(e ...))
|
||||
(all-vars '())
|
||||
(build (lambda (vars . e) e))
|
||||
(subterms '() e)]))
|
||||
|
||||
(define (maker? v)
|
||||
(and (symbol? v)
|
||||
(regexp-match #rx"^make-" (symbol->string v))))
|
||||
|
||||
(define p? (redex-match lang p))
|
||||
(define prim-op? (redex-match lang prim-op))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
((and true ... false e ...) . ==> . false)
|
||||
((and true ...) . ==> . true)
|
||||
((side-condition (and true ... v_1 e ...)
|
||||
(and (not (eq? (term v_1) 'true))
|
||||
(not (eq? (term v_1) 'false))))
|
||||
. e==> .
|
||||
"and: question result is not true or false")
|
||||
((or false ... true e ...) . ==> . true)
|
||||
((or false ...) . ==> . false)
|
||||
((side-condition (or false ... v_1 e ...)
|
||||
(and (not (eq? (term v_1) 'true))
|
||||
(not (eq? (term v_1) 'false))))
|
||||
. e==> .
|
||||
"or: question result is not true or false")
|
||||
|
||||
((if true e_1 e_2) . ==> . e_1)
|
||||
((if false e_1 e_2) . ==> . e_2)
|
||||
(e==> (if v_1 e_1 e_2)
|
||||
"if: question result is not true or false"
|
||||
(side-condition (and (not (eq? (term v_1) 'false))
|
||||
(not (eq? (term v_1) 'true)))))
|
||||
|
||||
|
||||
((cond (false e) ... (true e_1) (e_2 e_3) ...) . ==> . e_1)
|
||||
((cond (false e) ... (true e_1) (e_2 e_3) ... (else e_4)) . ==> . e_1)
|
||||
((cond (false e) ... (else e_1)) . ==> . e_1)
|
||||
((cond (false e) ...) . e==> . "cond: all question results were false")
|
||||
|
||||
((side-condition
|
||||
(cond (false e_1) ... (v_1 e_2) (e_3 e_4) ...)
|
||||
(and (not (eq? (term v_1) 'false))
|
||||
(not (eq? (term v_1) 'true))
|
||||
(not (eq? (term v_1) 'else))))
|
||||
. e==> .
|
||||
"cond: question result is not true or false")
|
||||
|
||||
((side-condition
|
||||
(cond (false e_1) ... (v_1 e_2) (e_3 e_4) ... (else e_5))
|
||||
(and (not (eq? (term v_1) 'false))
|
||||
(not (eq? (term v_1) 'true))
|
||||
(not (eq? (term v_1) 'else))))
|
||||
. e==> .
|
||||
"cond: question result is not true or false")
|
||||
|
||||
|
||||
((empty? empty) . ==> . true)
|
||||
((side-condition (empty? v_1)
|
||||
(not (eq? (term v_1) 'empty)))
|
||||
. ==> .
|
||||
false)
|
||||
((empty?) . e==> . "empty?: expects one argument")
|
||||
((empty? v_1 v_2 v_3 ...) . e==> . "empty?: expects one argument")
|
||||
|
||||
((side-condition (cons v v_1)
|
||||
(and (not (eq? (term v_1) 'empty))
|
||||
(not (and (pair? (term v_1))
|
||||
(eq? (car (term v_1)) 'cons)))))
|
||||
. e==> .
|
||||
"cons: second argument must be of type <list>")
|
||||
|
||||
((first (cons v_1 list-value)) . ==> . v_1)
|
||||
((first) . e==> . "first: expects one argument")
|
||||
((first v_1 v_2 v_3 ...) . e==> . "first: expects one argument")
|
||||
((side-condition (first v_1)
|
||||
(not (and (pair? (term v_1))
|
||||
(eq? (car (term v_1)) 'cons))))
|
||||
. e==> .
|
||||
"first: expects argument of type <pair>")
|
||||
|
||||
((rest (cons v list-value_1)) . ==> . list-value_1)
|
||||
((rest v_1 v_2 v_3 ...) . e==> . "rest: expects one argument")
|
||||
((rest) . e==> . "rest: expects one argument")
|
||||
|
||||
((side-condition (rest v_1)
|
||||
(not (and (pair? (term v_1))
|
||||
(eq? (car (term v_1)) 'cons))))
|
||||
. e==> .
|
||||
"rest: expects argument of type <pair>")
|
||||
|
||||
((symbol=? 'x_1 'x_2) . ==> . ,(if (eq? (term x_1) (term x_2)) (term true) (term false)))
|
||||
((side-condition (symbol=? v_1 v_2)
|
||||
(or (not (and (pair? (term v_1))
|
||||
(eq? (car (term v_1)) 'quote)))
|
||||
(not (and (pair? (term v_2))
|
||||
(eq? (car (term v_2)) 'quote)))))
|
||||
. e==> .
|
||||
"symbol=?: expects argument of type <symbol>")
|
||||
((symbol=?)
|
||||
. e==> .
|
||||
"procedure symbol=?: expects 2 arguments")
|
||||
((symbol=? v_1 v_2 v_3 v_4 ...)
|
||||
. e==> .
|
||||
"procedure symbol=?: expects 2 arguments")
|
||||
|
||||
((+ number_1 ...) . ==> . ,(apply + (term (number_1 ...))))
|
||||
((side-condition (+ v_arg ...)
|
||||
(ormap (lambda (v_arg) (not (number? v_arg))) (term (v_arg ...))))
|
||||
. e==> .
|
||||
"+: expects type <number>")
|
||||
|
||||
((side-condition (/ number_1 number_2 ...)
|
||||
(andmap (lambda (number_2) (not (zero? number_2))) (term (number_2 ...))))
|
||||
. ==> .
|
||||
,(apply / (term (number_1 number_2 ...))))
|
||||
((side-condition (/ number_1 number_2 ...)
|
||||
(ormap (lambda (number_2) (zero? number_2)) (term (number_2 ...))))
|
||||
. e==> .
|
||||
"/: division by zero")
|
||||
((side-condition (/ v_arg ...)
|
||||
(ormap (lambda (v_arg) (not (number? v_arg))) (term (v_arg ...))))
|
||||
. e==> .
|
||||
"/: expects type <number>")
|
||||
|
||||
;; unbound id application
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(in-hole d/e-ctxt (x_f v ...))
|
||||
d/e ...)
|
||||
(and (not (prim-op? (term x_f)))
|
||||
(not (defined? (term x_f) (term (d/e-v_before ...))))))
|
||||
,(format "reference to undefined identifier: ~a" (term x_f)))
|
||||
|
||||
;; procedure application as lambda
|
||||
(--> (d/e-v_before ...
|
||||
(define x_f (lambda (x_var ...) e_body))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt_1 (x_f v_arg ...))
|
||||
d/e_after ...)
|
||||
(d/e-v_before ...
|
||||
(define x_f (lambda (x_var ...) e_body))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt_1
|
||||
,(multi-subst (term (x_var ...))
|
||||
(term (v_arg ...))
|
||||
(term e_body)))
|
||||
d/e_after ...))
|
||||
|
||||
;; define-style procedure application
|
||||
(--> (d/e-v_before ...
|
||||
(define (x_f x_var ...) e_body)
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt (x_f v_arg ...))
|
||||
(name after d/e) ...)
|
||||
(d/e-v_before ...
|
||||
(define (x_f x_var ...) e_body)
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt
|
||||
,(multi-subst (term (x_var ...))
|
||||
(term (v_arg ...))
|
||||
(term e_body)))
|
||||
after ...))
|
||||
|
||||
;; reference to non-procedure define:
|
||||
(--> (d/e-v_before ...
|
||||
(name defn (define (name a x) (name val v)))
|
||||
d/e-v_middle ...
|
||||
(in-hole (name ctxt d/e-ctxt) (name a x))
|
||||
d/e_after ...)
|
||||
(d/e-v_before ...
|
||||
defn
|
||||
d/e-v_middle ...
|
||||
(in-hole ctxt val)
|
||||
d/e_after ...))
|
||||
|
||||
;; unbound reference to top-level id in hole:
|
||||
(-->
|
||||
(side-condition
|
||||
(d/e-v_before ...
|
||||
(in-hole d/e-ctxt (name a x))
|
||||
d/e ...)
|
||||
(and (not (prim-op? (term a)))
|
||||
(not (defined? (term a) (term (d/e-v_before ...))))))
|
||||
,(format "reference to undefined identifier: ~a" (term a)))
|
||||
|
||||
;; reference to procedure-bound var in hole:
|
||||
(--> (d/e-v ...
|
||||
(define (x_f x_var ...) (name body e))
|
||||
d/e-v ...
|
||||
(in-hole d/e-ctxt x_f)
|
||||
d/e ...)
|
||||
,(format "~a is a procedure, so it must be applied to arguments" (term x_f)))
|
||||
|
||||
;; reference to non-procedure-bound-var in application
|
||||
(--> (d/e-v ...
|
||||
(define x_a v_val)
|
||||
d/e-v ...
|
||||
(in-hole d/e-ctxt (x_a v ...))
|
||||
d/e ...)
|
||||
,(format "procedure application: expected procedure, given: ~a" (term v_val)))
|
||||
|
||||
((struct? ((name maker maker) v ...)) . ==> . true)
|
||||
((struct? non-struct-value) . ==> . false)
|
||||
|
||||
;; struct predicate passes
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt (x_predicate (x_maker v_arg ...)))
|
||||
d/e_after ...)
|
||||
(and (maker-name-match? (term x_struct) (term x_maker))
|
||||
(predicate-name-match? (term x_struct) (term x_predicate))))
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt true)
|
||||
d/e_after ...))
|
||||
|
||||
;; struct predicate fail to another struct
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt (x_predicate (x_maker v ...)))
|
||||
(name after d/e) ...)
|
||||
(and (not (maker-name-match? (term x_struct) (term x_maker)))
|
||||
(predicate-name-match? (term x_struct) (term x_predicate))))
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt false)
|
||||
after ...))
|
||||
|
||||
;; struct predicate fail to another value
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole (name ctxt d/e-ctxt) (x_predicate non-struct-value))
|
||||
d/e_after ...)
|
||||
(predicate-name-match? (term x_struct) (term x_predicate)))
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole ctxt false)
|
||||
d/e_after ...))
|
||||
|
||||
;; misapplied selector 1
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt (x_selector (x_maker v_arg ...)))
|
||||
d/e_after ...)
|
||||
(and (not (maker-name-match? (term x_struct) (term x_maker)))
|
||||
(selector-name-match? (term x_struct) (term (x_field ...)) (term x_selector))))
|
||||
,(format "~a: expects argument of matching struct" (term x_selector)))
|
||||
|
||||
;; misapplied selector 2
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole d/e-ctxt (x_selector non-struct-value))
|
||||
d/e_after ...)
|
||||
(selector-name-match? (term x_struct) (term (x_field ...)) (term x_selector)))
|
||||
,(format "~a: expects argument of matching struct" (term x_selector)))
|
||||
|
||||
;; well-applied selector
|
||||
(--> (side-condition
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole (name ctxt d/e-ctxt) (x_selector (x_maker v_arg ...)))
|
||||
d/e_after ...)
|
||||
(and (maker-name-match? (term x_struct) (term x_maker))
|
||||
(selector-name-match? (term x_struct) (term (x_field ...)) (term x_selector))))
|
||||
(d/e-v_before ...
|
||||
(define-struct x_struct (x_field ...))
|
||||
d/e-v_middle ...
|
||||
(in-hole ctxt
|
||||
,(list-ref (term (v_arg ...))
|
||||
(struct-index (term x_struct)
|
||||
(term (x_field ...))
|
||||
(term x_selector))))
|
||||
d/e_after ...))
|
||||
|
||||
where
|
||||
[(==> a b) (--> (in-hole p-ctxt_1 a) (in-hole p-ctxt_1 b))]
|
||||
[(e==> a b) (--> (in-hole p-ctxt a) b)]))
|
||||
|
||||
(define (defined? f befores)
|
||||
(ormap
|
||||
(lambda (before)
|
||||
(match before
|
||||
[`(define (,a-name ,@(x ...)) ,b)
|
||||
(eq? f a-name)]
|
||||
[`(define ,a-name (lambda ,@(x ...)))
|
||||
(eq? f a-name)]
|
||||
[`(define-struct ,struct-name (,@(fields ...)))
|
||||
(or (ormap (lambda (field)
|
||||
(eq? f (string->symbol (format "~a-~a" struct-name field))))
|
||||
fields)
|
||||
(eq? f (string->symbol (format "make-~a" struct-name)))
|
||||
(eq? f (string->symbol (format "~a?" struct-name))))]
|
||||
[else #t]))
|
||||
befores))
|
||||
|
||||
(define (multi-subst orig-vars orig-args body)
|
||||
(let loop ([args orig-args]
|
||||
[vars orig-vars]
|
||||
[body body])
|
||||
(cond
|
||||
[(and (null? args) (null? vars))
|
||||
body]
|
||||
[(or (null? args) (null? vars))
|
||||
(error 'multi-subst
|
||||
"malformed program, formals ~s and actuals ~s do not have the same size"
|
||||
orig-vars
|
||||
orig-args)]
|
||||
[else (loop (cdr args)
|
||||
(cdr vars)
|
||||
(beg-e-subst (car vars) (car args) body))])))
|
||||
|
||||
(define (selector-name-match? struct fields selector)
|
||||
(ormap (lambda (field) (string=? (format "~a-~a" struct field)
|
||||
(symbol->string selector)))
|
||||
fields))
|
||||
|
||||
(define (struct-index struct init-fields selector)
|
||||
(let loop ([i 0]
|
||||
[fields init-fields])
|
||||
(cond
|
||||
[(null? fields) (error 'struct-index "~s ~s ~s" struct init-fields selector)]
|
||||
[else (let ([field (car fields)])
|
||||
(if (string=? (format "~a-~a" struct field)
|
||||
(symbol->string selector))
|
||||
i
|
||||
(loop (+ i 1)
|
||||
(cdr fields))))])))
|
||||
|
||||
(define (maker-name-match? name maker)
|
||||
(let* ([names (symbol->string name)]
|
||||
[makers (symbol->string maker)]
|
||||
[namel (string-length names)]
|
||||
[makerl (string-length makers)])
|
||||
(and (makerl . > . namel)
|
||||
(string=? (substring makers (- makerl namel) makerl)
|
||||
names))))
|
||||
|
||||
(define (predicate-name-match? name predicate)
|
||||
(eq? (string->symbol (format "~a?" name)) predicate))
|
||||
|
||||
(define failed-tests 0)
|
||||
(define total-tests 0)
|
||||
|
||||
(define (test in out)
|
||||
(set! total-tests (+ total-tests 1))
|
||||
(let/ec k
|
||||
(let* ([failed
|
||||
(lambda (msg)
|
||||
(set! failed-tests (+ failed-tests 1))
|
||||
(fprintf (current-error-port) "FAILED: ~a\n" msg)
|
||||
(k (void)))]
|
||||
[got (normalize in failed)])
|
||||
(unless (equal? got out)
|
||||
(fprintf (current-error-port) "FAILED: ~s\ngot: ~s\nexpected: ~s\n" in got out)
|
||||
(set! failed-tests (+ failed-tests 1))))))
|
||||
|
||||
(define (test-all step . steps)
|
||||
(set! total-tests (+ total-tests 1))
|
||||
(let loop ([this step]
|
||||
[rest steps])
|
||||
(let ([nexts (apply-reduction-relation reductions this)])
|
||||
(cond
|
||||
[(null? rest)
|
||||
(unless (null? nexts)
|
||||
(set! failed-tests (+ failed-tests 1))
|
||||
(fprintf (current-error-port) "FAILED: ~s\n last step: ~s\n reduced to: ~s\n"
|
||||
step
|
||||
this
|
||||
nexts))]
|
||||
[else
|
||||
(cond
|
||||
[(and (pair? nexts)
|
||||
(null? (cdr nexts)))
|
||||
(let ([next (car nexts)])
|
||||
(if (equal? next (car rest))
|
||||
(loop (car rest)
|
||||
(cdr rest))
|
||||
(begin
|
||||
(set! failed-tests (+ failed-tests 1))
|
||||
(fprintf (current-error-port)
|
||||
"FAILED: ~s\n step: ~s\n expected: ~s\n got: ~s\n"
|
||||
step
|
||||
this
|
||||
(car rest)
|
||||
next))))]
|
||||
[else
|
||||
(set! failed-tests (+ failed-tests 1))
|
||||
(fprintf (current-error-port)
|
||||
"FAILED: ~s\n step: ~s\n not single step: ~s\n"
|
||||
step
|
||||
this
|
||||
nexts)])]))))
|
||||
|
||||
(define show-dots (make-parameter #f))
|
||||
(define (normalize orig-term failed)
|
||||
(let loop ([term orig-term]
|
||||
[n 1000])
|
||||
(unless (p? term)
|
||||
(failed (format "not a p: ~s orig: ~s" term orig-term)))
|
||||
(let ([nexts (apply-reduction-relation reductions term)])
|
||||
(when (show-dots)
|
||||
(display #\.)
|
||||
(flush-output))
|
||||
(cond
|
||||
[(= n 0)
|
||||
(when (show-dots)
|
||||
(newline))
|
||||
(error 'normalize "found too many reductions")]
|
||||
[(null? nexts)
|
||||
(when (show-dots)
|
||||
(newline))
|
||||
term]
|
||||
[(string? (car nexts))
|
||||
(when (show-dots)
|
||||
(newline))
|
||||
(car nexts)]
|
||||
[(null? (cdr nexts)) (loop (car nexts) (- n 1))]
|
||||
[else
|
||||
(when (show-dots)
|
||||
(newline))
|
||||
(failed (format "found more than one reduction\n ~s\n ->\n~s" term nexts))]))))
|
||||
|
||||
(define (show-test-results)
|
||||
(cond
|
||||
[(= failed-tests 0)
|
||||
(fprintf (current-error-port) "passed all ~a tests\n" total-tests)]
|
||||
[else
|
||||
(fprintf (current-error-port) "failed ~a out of ~a tests\n" failed-tests total-tests)]))
|
||||
|
||||
(define-syntax (tests stx)
|
||||
(syntax-case stx ()
|
||||
[(_ args ...)
|
||||
(syntax
|
||||
(begin
|
||||
(set! failed-tests 0)
|
||||
(set! total-tests 0)
|
||||
args ...
|
||||
(show-test-results)))]))
|
||||
|
||||
(define (run-tests)
|
||||
(tests
|
||||
(test
|
||||
'((define-struct s ())
|
||||
(s? (make-s)))
|
||||
'((define-struct s ())
|
||||
true))
|
||||
|
||||
(test
|
||||
'((define-struct s (a b))
|
||||
(s-a (make-s 1 3)))
|
||||
'((define-struct s (a b))
|
||||
1))
|
||||
|
||||
(test
|
||||
'((define-struct s (a b))
|
||||
(s-b (make-s 1 3)))
|
||||
'((define-struct s (a b))
|
||||
3))
|
||||
|
||||
(test
|
||||
'((define-struct s (a b))
|
||||
(define-struct t (x y))
|
||||
(t-x (make-s 1 2)))
|
||||
"t-x: expects argument of matching struct")
|
||||
|
||||
(test
|
||||
'((define-struct t (x y))
|
||||
(t-x 12))
|
||||
"t-x: expects argument of matching struct")
|
||||
|
||||
(test
|
||||
'((define-struct s (a b))
|
||||
(define-struct t (x y))
|
||||
(s? (make-s 1 2)))
|
||||
'((define-struct s (a b))
|
||||
(define-struct t (x y))
|
||||
true))
|
||||
|
||||
(test
|
||||
'((define-struct s (a b))
|
||||
(define-struct t (x y))
|
||||
(t? (make-s 1 2)))
|
||||
'((define-struct s (a b))
|
||||
(define-struct t (x y))
|
||||
false))
|
||||
|
||||
(test
|
||||
'((define-struct s (a b))
|
||||
(struct? (make-s 1 2))
|
||||
(struct? 1))
|
||||
'((define-struct s (a b))
|
||||
true
|
||||
false))
|
||||
|
||||
(test
|
||||
'((define (f x) x)
|
||||
(f 1))
|
||||
'((define (f x) x)
|
||||
1))
|
||||
|
||||
(test
|
||||
'((define (double l) (+ l l))
|
||||
(double 2))
|
||||
'((define (double l) (+ l l))
|
||||
4))
|
||||
|
||||
(test
|
||||
'((define f (lambda (x) x))
|
||||
(f 1))
|
||||
'((define f (lambda (x) x))
|
||||
1))
|
||||
|
||||
(test
|
||||
'((define double (lambda (l) (+ l l)))
|
||||
(double 2))
|
||||
'((define double (lambda (l) (+ l l)))
|
||||
4))
|
||||
|
||||
(test
|
||||
'((f 1))
|
||||
"reference to undefined identifier: f")
|
||||
|
||||
(test
|
||||
'((f 1)
|
||||
(define (f x) x))
|
||||
"reference to undefined identifier: f")
|
||||
|
||||
(test
|
||||
'((make-s 1)
|
||||
(define-struct s (a b)))
|
||||
"reference to undefined identifier: make-s")
|
||||
|
||||
(test
|
||||
'((+ 1 2 3))
|
||||
'(6))
|
||||
|
||||
(test
|
||||
'((+ 1 "2" 3))
|
||||
"+: expects type <number>")
|
||||
|
||||
(test
|
||||
'((/ 1 2 3))
|
||||
'(1/6))
|
||||
|
||||
(test
|
||||
'((/ 1 2 0 3))
|
||||
"/: division by zero")
|
||||
|
||||
(test
|
||||
'((/ 1 "2" 3))
|
||||
"/: expects type <number>")
|
||||
|
||||
(test '((+ 1 (/ (+ 3 5) (+ 2 2)))) '(3))
|
||||
|
||||
(test '((symbol=? 'x 'x)) '(true))
|
||||
(test '((symbol=? 'x 'y)) '(false))
|
||||
(test '((symbol=? 1 'x))
|
||||
"symbol=?: expects argument of type <symbol>")
|
||||
(test '((symbol=? 'x 1))
|
||||
"symbol=?: expects argument of type <symbol>")
|
||||
|
||||
(test '((cons 1 empty)) '((cons 1 empty)))
|
||||
(test '((cons 1 2))
|
||||
"cons: second argument must be of type <list>")
|
||||
(test '((+ (first (cons 1 2)) 2))
|
||||
"cons: second argument must be of type <list>")
|
||||
(test '((+ (first (cons 1 empty)) 2))
|
||||
'(3))
|
||||
|
||||
(test
|
||||
'((first (cons 1 empty)))
|
||||
'(1))
|
||||
|
||||
(test
|
||||
'((first 1))
|
||||
"first: expects argument of type <pair>")
|
||||
|
||||
(test
|
||||
'((first 1 2))
|
||||
"first: expects one argument")
|
||||
|
||||
(test
|
||||
'((first))
|
||||
"first: expects one argument")
|
||||
|
||||
(test
|
||||
'((rest (cons 1 empty)))
|
||||
'(empty))
|
||||
|
||||
(test
|
||||
'((rest 1))
|
||||
"rest: expects argument of type <pair>")
|
||||
|
||||
(test
|
||||
'((rest 1 2))
|
||||
"rest: expects one argument")
|
||||
|
||||
(test
|
||||
'((rest))
|
||||
"rest: expects one argument")
|
||||
|
||||
(test
|
||||
'((empty? empty))
|
||||
'(true))
|
||||
|
||||
(test
|
||||
'((empty? 1))
|
||||
'(false))
|
||||
|
||||
(test
|
||||
'((empty?))
|
||||
"empty?: expects one argument")
|
||||
|
||||
(test
|
||||
'((empty? 1 2))
|
||||
"empty?: expects one argument")
|
||||
|
||||
(test
|
||||
'((cond [true 1]))
|
||||
'(1))
|
||||
|
||||
(test
|
||||
'((cond [else 1]))
|
||||
'(1))
|
||||
|
||||
(test-all
|
||||
'((cond [false 1] [else 2]))
|
||||
'(2))
|
||||
|
||||
(test-all
|
||||
'((cond [false 1] [false 2]))
|
||||
"cond: all question results were false")
|
||||
|
||||
(test
|
||||
'((cond [1 1]))
|
||||
"cond: question result is not true or false")
|
||||
|
||||
(test
|
||||
'((cond [(empty? empty) 'infinite] [else 3]))
|
||||
'('infinite))
|
||||
|
||||
(test-all
|
||||
'((cond [(if false false false) 'x] [(if true true true) 'y] [(if false false false) 'z]))
|
||||
'((cond [false 'x] [(if true true true) 'y] [(if false false false) 'z]))
|
||||
'((cond [false 'x] [true 'y] [(if false false false) 'z]))
|
||||
'('y))
|
||||
|
||||
(test-all
|
||||
'((cond [(if false false false) 'x] [(if true true true) 'y] [else 'z]))
|
||||
'((cond [false 'x] [(if true true true) 'y] [else 'z]))
|
||||
'((cond [false 'x] [true 'y] [else 'z]))
|
||||
'('y))
|
||||
|
||||
(test-all
|
||||
'((cond [(if false false false) 'x] [(if false false false) 'y] [else 'z]))
|
||||
'((cond [false 'x] [(if false false false) 'y] [else 'z]))
|
||||
'((cond [false 'x] [false 'y] [else 'z]))
|
||||
'('z))
|
||||
|
||||
(test-all
|
||||
'((and true true 3))
|
||||
"and: question result is not true or false")
|
||||
|
||||
(test-all
|
||||
'((and 1 true true))
|
||||
"and: question result is not true or false")
|
||||
|
||||
(test-all
|
||||
'((and true true true false))
|
||||
'(false))
|
||||
|
||||
(test-all
|
||||
'((and false true))
|
||||
'(false))
|
||||
|
||||
(test-all
|
||||
'((or false false 3))
|
||||
"or: question result is not true or false")
|
||||
|
||||
(test-all
|
||||
'((or 1 false false))
|
||||
"or: question result is not true or false")
|
||||
|
||||
(test-all
|
||||
'((or false false false true))
|
||||
'(true))
|
||||
|
||||
(test-all
|
||||
'((or true false))
|
||||
'(true))
|
||||
|
||||
(test-all
|
||||
'((or (if false false false) (if false false false) (if true true true) (if false false false)))
|
||||
'((or false (if false false false) (if true true true) (if false false false)))
|
||||
'((or false false (if true true true) (if false false false)))
|
||||
'((or false false true (if false false false)))
|
||||
'(true))
|
||||
|
||||
(test-all
|
||||
'((and (if true true true) (if true true true) (if false false false) (if true true true)))
|
||||
'((and true (if true true true) (if false false false) (if true true true)))
|
||||
'((and true true (if false false false) (if true true true)))
|
||||
'((and true true false (if true true true)))
|
||||
'(false))
|
||||
|
||||
(test
|
||||
'((if 1 2 3))
|
||||
"if: question result is not true or false")
|
||||
|
||||
(test
|
||||
'((if true 'x 'y))
|
||||
'('x))
|
||||
|
||||
(test
|
||||
'((if false 'x 'y))
|
||||
'('y))
|
||||
|
||||
; test non-procedure-defs in context:
|
||||
(test
|
||||
`((+ 3 4) (define a 3) (+ 5 6))
|
||||
`(7 (define a 3) 11))
|
||||
|
||||
; test reduction of non-procedure-defs:
|
||||
(test
|
||||
`((define a 13) (define b (+ a 9)) (+ 3 4))
|
||||
`((define a 13) (define b 22) 7))
|
||||
|
||||
; test reduction of unbound ids in hole:
|
||||
(test
|
||||
`(x)
|
||||
"reference to undefined identifier: x")
|
||||
|
||||
; test reduction of function-bound id in hole:
|
||||
(test
|
||||
`((define (a x) (+ x 1)) a)
|
||||
"a is a procedure, so it must be applied to arguments")
|
||||
|
||||
; test reduction of non-procedure-def in application:
|
||||
(test
|
||||
`((define a 3) (a 9))
|
||||
"procedure application: expected procedure, given: 3")))
|
||||
|
||||
(define (run-big-test)
|
||||
(parameterize ([show-dots #t])
|
||||
(tests
|
||||
(test
|
||||
'((define-struct pr (hd tl))
|
||||
(define (avg l)
|
||||
(cond
|
||||
[(empty? l) 'infinite]
|
||||
[else (/ (sum l) (howmany/acc l 0))]))
|
||||
(define (sum l)
|
||||
(cond
|
||||
[(empty? (pr-tl l)) (pr-hd l)]
|
||||
[else (+ (pr-hd l) (sum (pr-tl l)))]))
|
||||
(define (howmany/acc l acc)
|
||||
(cond
|
||||
[(empty? l) acc]
|
||||
[else (howmany/acc (pr-tl l) (+ acc 1))]))
|
||||
(avg empty)
|
||||
(avg (make-pr 3 (make-pr 4 (make-pr 5 (make-pr 6 (make-pr 7 (make-pr 8 (make-pr 9 empty)))))))))
|
||||
|
||||
'((define-struct pr (hd tl))
|
||||
(define (avg l)
|
||||
(cond
|
||||
[(empty? l) 'infinite]
|
||||
[else (/ (sum l) (howmany/acc l 0))]))
|
||||
(define (sum l)
|
||||
(cond
|
||||
[(empty? (pr-tl l)) (pr-hd l)]
|
||||
[else (+ (pr-hd l) (sum (pr-tl l)))]))
|
||||
(define (howmany/acc l acc)
|
||||
(cond
|
||||
[(empty? l) acc]
|
||||
[else (howmany/acc (pr-tl l) (+ acc 1))]))
|
||||
'infinite
|
||||
6))
|
||||
(test
|
||||
'((define (contains-sym? s l)
|
||||
(cond
|
||||
[(empty? l) false]
|
||||
[true (or (symbol=? s (first l))
|
||||
(contains-sym? s (rest l)))]))
|
||||
(contains-sym? 'x (cons 'z (cons 'y (cons 'x empty))))
|
||||
(contains-sym? 'a (cons 'p (cons 'q (cons 'p (cons 'q (cons 'p (cons 'q empty))))))))
|
||||
'((define (contains-sym? s l)
|
||||
(cond
|
||||
[(empty? l) false]
|
||||
[true (or (symbol=? s (first l))
|
||||
(contains-sym? s (rest l)))]))
|
||||
true
|
||||
false)))))
|
||||
|
||||
;; timing test
|
||||
;#;
|
||||
(time (run-tests)
|
||||
(run-big-test)))
|
||||
|
||||
57
collects/redex/examples/church.ss
Normal file
57
collects/redex/examples/church.ss
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
(module church mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
(define-language lang
|
||||
(e (lambda (x) e)
|
||||
(let (x e) e)
|
||||
(app e e)
|
||||
(+ e e)
|
||||
number
|
||||
x)
|
||||
(e-ctxt (lambda (x) e-ctxt)
|
||||
a-ctxt)
|
||||
(a-ctxt (let (x a-ctxt) e)
|
||||
(app a-ctxt e)
|
||||
(app x a-ctxt)
|
||||
hole)
|
||||
(v (lambda (x) e)
|
||||
x)
|
||||
(x variable))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole e-ctxt_1 (app (lambda (x_1) e_body) e_arg))
|
||||
(in-hole e-ctxt_1 (subst (x_1 e_arg e_body))))
|
||||
(--> (in-hole e-ctxt_1 (let (x_1 v_1) e_1))
|
||||
(in-hole e-ctxt_1 (subst (x_1 v_1 e_1))))))
|
||||
|
||||
(define-metafunction subst
|
||||
lang
|
||||
[(x_1 e_1 (lambda (x_1) e_2)) (lambda (x_1) e_2)]
|
||||
[(x_1 e_1 (lambda (x_2) e_2))
|
||||
,(term-let ((x_new (variable-not-in (term e_1) (term x_2))))
|
||||
(term (lambda (x_new) (subst (x_1 e_1 (subst (x_2 x_new e_2)))))))]
|
||||
[(x_1 e_1 (let (x_1 e_2) e_3)) (let (x_1 (subst (x_1 e_1 e_2))) e_3)]
|
||||
[(x_1 e_1 (let (x_2 e_2) e_3))
|
||||
,(term-let ((x_new (variable-not-in (term e_1) (term x_2))))
|
||||
(term (let (x_2 (subst (x_1 e_1 e_2))) (subst (x_1 e_1 (subst (x_2 x_new e_3)))))))]
|
||||
[(x_1 e_1 x_1) e_1]
|
||||
[(x_1 e_1 x_2) x_2]
|
||||
[(x_1 e_1 (app e_2 e_3)) (app (subst (x_1 e_1 e_2))
|
||||
(subst (x_1 e_1 e_3)))]
|
||||
[(x_1 e_1 (+ e_2 e_3)) (+ (subst (x_1 e_1 e_2))
|
||||
(subst (x_1 e_1 e_3)))]
|
||||
[(x_1 e_1 number_1) number_1])
|
||||
|
||||
(traces lang reductions
|
||||
'(let (plus (lambda (m)
|
||||
(lambda (n)
|
||||
(lambda (s)
|
||||
(lambda (z)
|
||||
(app (app m s) (app (app n s) z)))))))
|
||||
(let (two (lambda (s) (lambda (z) (app s (app s z)))))
|
||||
(app (app plus two) two)))))
|
||||
90
collects/redex/examples/combinators.ss
Normal file
90
collects/redex/examples/combinators.ss
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
;"one point basis"
|
||||
;"formal aspects of computing"
|
||||
|
||||
(module combinators mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(initial-font-size 12)
|
||||
(reduction-steps-cutoff 100)
|
||||
(initial-char-width 80)
|
||||
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
comb
|
||||
abs1
|
||||
abs2
|
||||
abs3)
|
||||
(e-ctxt (e e-ctxt)
|
||||
(e-ctxt e)
|
||||
hole)
|
||||
(comb i
|
||||
j
|
||||
b
|
||||
c
|
||||
c*
|
||||
w))
|
||||
|
||||
(define ij-relation
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole e-ctxt_1 (i e_1))
|
||||
(in-hole e-ctxt_1 e_1))
|
||||
(--> (in-hole e-ctxt_1 ((((j e_a) e_b) e_c) e_d))
|
||||
(in-hole e-ctxt_1 ((e_a e_b) ((e_a e_d) e_c))))))
|
||||
|
||||
(define relation
|
||||
(union-reduction-relations
|
||||
ij-relation
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole e-ctxt_1 (((b e_m) e_n) e_l))
|
||||
(in-hole e-ctxt_1 (e_m (e_n e_l))))
|
||||
(--> (in-hole e-ctxt_1 (((c e_m) e_n) e_l))
|
||||
(in-hole e-ctxt_1 ((e_m e_l) e_n)))
|
||||
(--> (in-hole e-ctxt_1 ((c* e_a) e_b))
|
||||
(in-hole e-ctxt_1 (e_b e_a)))
|
||||
(--> (in-hole e-ctxt_1 ((w e_a) e_b))
|
||||
(in-hole e-ctxt_1 ((e_a e_b) e_b))))))
|
||||
|
||||
|
||||
(define c* `((j i) i))
|
||||
(define (make-c c*) `(((j ,c*) (j ,c*)) (j ,c*)))
|
||||
(define (make-b c) `((,c ((j i) ,c)) (j i)))
|
||||
(define (make-w b c c*) `(,c ((,c ((,b ,c) ((,c ((,b j) ,c*)) ,c*))) ,c*)))
|
||||
(define (make-s b c w) `((,b ((,b (,b ,w)) ,c)) (,b ,b)))
|
||||
|
||||
(traces/multiple lang
|
||||
relation
|
||||
(list
|
||||
`((,c* abs1) abs2)
|
||||
`(((,(make-c 'c*) abs1) abs2) abs3)
|
||||
`(((,(make-b 'c) abs1) abs2) abs3)
|
||||
`((,(make-w 'b 'c 'c*) abs1) abs2)
|
||||
`(((,(make-s 'b 'c 'w) abs1) abs2) abs3)))
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
#;
|
||||
(let loop ([t (make-s (make-b (make-c c*))
|
||||
(make-c c*)
|
||||
(make-w (make-b (make-c c*))
|
||||
(make-c c*)
|
||||
c*))]
|
||||
[i 0])
|
||||
(when (zero? (modulo i 100))
|
||||
(display i)
|
||||
(display " ")
|
||||
(flush-output))
|
||||
(let ([next (apply-reduction-relation ij-relation t)])
|
||||
(if (null? next)
|
||||
(begin (newline)
|
||||
(pretty-print t))
|
||||
(loop (car next) (+ i 1)))))
|
||||
|
||||
#;
|
||||
(traces lang ij-relation
|
||||
(make-s (make-b (make-c c*))
|
||||
(make-c c*)
|
||||
(make-w (make-b (make-c c*))
|
||||
(make-c c*)
|
||||
c*))))
|
||||
18
collects/redex/examples/compatible-closure.ss
Normal file
18
collects/redex/examples/compatible-closure.ss
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
(module compatible-closure mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(define-language grammar
|
||||
(B t
|
||||
f
|
||||
(B * B)))
|
||||
|
||||
(define r
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (f * B_1) B_1 false) ; [a]
|
||||
(--> (t * B_1) t true))) ; [b]
|
||||
|
||||
(define ->r (compatible-closure r grammar B))
|
||||
|
||||
(traces grammar ->r '((f * f) * (t * f))))
|
||||
67
collects/redex/examples/eta.ss
Normal file
67
collects/redex/examples/eta.ss
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
(module eta mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui)
|
||||
(planet robby/redex:5/subst))
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
x
|
||||
(+ e e)
|
||||
v)
|
||||
(c (v c)
|
||||
(c e)
|
||||
(+ v c)
|
||||
(+ c e)
|
||||
hole)
|
||||
(v (lambda (x) e)
|
||||
number)
|
||||
(x (variable-except lambda +)))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(c=> ((lambda (variable_x) e_body) v_arg)
|
||||
,(lc-subst (term variable_x) (term v_arg) (term e_body)))
|
||||
(c=> (+ number_1 number_2)
|
||||
,(+ (term number_1) (term number_2)))
|
||||
(c=> (side-condition (lambda (variable_x) (e_fun variable_x))
|
||||
(equal? (term e_fun) (lc-subst (term variable_x) 1234 (term e_fun))))
|
||||
e_fun)
|
||||
|
||||
(--> (in-hole c (number_n v_arg))
|
||||
,(format "procedure application: expected procedure, given: ~a; arguments were: ~a"
|
||||
(term number_n)
|
||||
(term v_arg)))
|
||||
(--> (in-hole c (+ (name non-num (lambda (variable) e)) (name arg2 v)))
|
||||
,(format "+: expects type <number> as 1st argument, given: ~s; other arguments were: ~s"
|
||||
(term non-num) (term arg2)))
|
||||
(--> (in-hole c (+ (name arg1 v) (name non-num (lambda (variable) e))))
|
||||
,(format "+: expects type <number> as 2nd argument, given: ~s; other arguments were: ~s"
|
||||
(term arg1) (term non-num)))
|
||||
|
||||
where
|
||||
|
||||
[(c=> x y) (--> (in-hole c_1 x) (in-hole c_1 y))]))
|
||||
|
||||
(define lc-subst
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(+ ,n2 ,n1)
|
||||
(all-vars '())
|
||||
(build (lambda (vars n1 n2) `(+ ,n1 ,n1)))
|
||||
(subterm '() n1)
|
||||
(subterm '() n2)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
(traces lang reductions '(+ (lambda (x) ((+ 1 2) x)) 1)))
|
||||
2
collects/redex/examples/info.ss
Normal file
2
collects/redex/examples/info.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "Reduction Semantics examples"))
|
||||
254
collects/redex/examples/iswim.ss
Normal file
254
collects/redex/examples/iswim.ss
Normal file
|
|
@ -0,0 +1,254 @@
|
|||
(module iswim mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "contract.ss"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Expression grammar:
|
||||
|
||||
(define-language iswim-grammar
|
||||
(M (M M)
|
||||
(o1 M)
|
||||
(o2 M M)
|
||||
V
|
||||
("letcc" X M)
|
||||
("cc" M M))
|
||||
(V X
|
||||
("lam" variable M)
|
||||
b
|
||||
("[" M "]"))
|
||||
(X variable)
|
||||
(b number)
|
||||
(o1 "add1" "sub1" "iszero")
|
||||
(o2 "+" "-" "*" "^")
|
||||
(on o1 o2)
|
||||
|
||||
;; Evaluation contexts:
|
||||
(E hole
|
||||
(E M)
|
||||
(V E)
|
||||
(o1 E)
|
||||
(o2 E M)
|
||||
(o2 V E)
|
||||
("cc" E M)
|
||||
("cc" V E))
|
||||
|
||||
;; Continuations (CK machine):
|
||||
(k "mt"
|
||||
("fun" V k)
|
||||
("arg" M k)
|
||||
("narg" (V ... on) (M ...) k))
|
||||
|
||||
;; Environments and closures (CEK):
|
||||
(env ((X = vcl) ...))
|
||||
(cl (M : env))
|
||||
(vcl (V- : env))
|
||||
|
||||
;; Values that are not variables:
|
||||
(V- ("lam" variable M)
|
||||
b)
|
||||
|
||||
;; Continuations with closures (CEK):
|
||||
(k- "mt"
|
||||
("fun" vcl k-)
|
||||
("arg" cl k-)
|
||||
("narg" (vcl ... on) (cl ...) k-)))
|
||||
|
||||
(define M? (redex-match iswim-grammar M))
|
||||
(define V? (redex-match iswim-grammar V))
|
||||
(define o1? (redex-match iswim-grammar o1))
|
||||
(define o2? (redex-match iswim-grammar o2))
|
||||
(define on? (redex-match iswim-grammar on))
|
||||
(define k? (redex-match iswim-grammar k))
|
||||
|
||||
(define env? (redex-match iswim-grammar env))
|
||||
(define cl? (redex-match iswim-grammar cl))
|
||||
(define vcl? (redex-match iswim-grammar vcl))
|
||||
(define k-? (redex-match iswim-grammar k-))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Substitution:
|
||||
|
||||
;; The subst form makes implemention of capture-avoiding
|
||||
;; easier. We just have to describe how variables bind
|
||||
;; in our language's forms.
|
||||
|
||||
(define iswim-subst/backwards
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`("lam" ,X ,M)
|
||||
(all-vars (list X))
|
||||
(build (lambda (X-list M) `("lam" ,(car X-list) ,M)))
|
||||
(subterm (list X) M)]
|
||||
[`(,(and o (or "add1" "sub1" "iszero")) ,M1)
|
||||
(all-vars '())
|
||||
(build (lambda (vars M1) `(,o ,M1)))
|
||||
(subterm '() M1)]
|
||||
[`(,(and o (or "+" "-" "*" "^")) ,M1 ,M2)
|
||||
(all-vars '())
|
||||
(build (lambda (vars M1 M2) `(,o ,M1 ,M2)))
|
||||
(subterm '() M1)
|
||||
(subterm '() M2)]
|
||||
[`(,M1 ,M2)
|
||||
(all-vars '())
|
||||
(build (lambda (empty-list M1 M2) `(,M1 ,M2)))
|
||||
(subterm '() M1)
|
||||
(subterm '() M2)]
|
||||
[`("letcc" ,X ,M)
|
||||
(all-vars (list X))
|
||||
(build (lambda (X-list M) `("letcc" ,(car X-list) ,M)))
|
||||
(subterm (list X) M)]
|
||||
[`("cc" ,M1 ,M2)
|
||||
(all-vars '())
|
||||
(build (lambda (vars M1 M2) `("cc" ,M1 ,M2)))
|
||||
(subterm '() M1)
|
||||
(subterm '() M2)]
|
||||
[`("[" ,E "]")
|
||||
(all-vars '())
|
||||
(build (lambda (vars) `("[" ,E "]")))]))
|
||||
|
||||
|
||||
;; the argument order for the subst-generated function
|
||||
;; doesn't match the order in the notes:
|
||||
(define (iswim-subst M Xr Mr)
|
||||
(iswim-subst/backwards Xr Mr M))
|
||||
|
||||
(define empty-env '())
|
||||
|
||||
;; Environment lookup
|
||||
(define (env-lookup env X)
|
||||
(let ([m (assq X env)])
|
||||
(and m (caddr m))))
|
||||
|
||||
;; Environment extension
|
||||
(define (env-extend env X vcl)
|
||||
(cons (list X '= vcl) env))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Reductions:
|
||||
|
||||
;; beta_v reduction
|
||||
(define beta_v
|
||||
(reduction-relation
|
||||
iswim-grammar
|
||||
(--> (("lam" X_1 M_1) V_1)
|
||||
,(iswim-subst (term M_1) (term X_1) (term V_1)))))
|
||||
|
||||
(define delta
|
||||
(reduction-relation
|
||||
iswim-grammar
|
||||
(--> ("add1" b_1) ,(add1 (term b_1)))
|
||||
(--> ("sub1" b_1) ,(sub1 (term b_1)))
|
||||
(--> ("iszero" b_1)
|
||||
,(if (zero? (term b_1))
|
||||
(term ("lam" x ("lam" y x)))
|
||||
(term ("lam" x ("lam" y y)))))
|
||||
(--> ("+" b_1 b_2) ,(+ (term b_1) (term b_2)))
|
||||
(--> ("-" b_1 b_2) ,(- (term b_1) (term b_2)))
|
||||
(--> ("*" b_1 b_2) ,(* (term b_1) (term b_2)))
|
||||
(--> ("^" b_1 b_2) ,(expt (term b_1) (term b_2)))))
|
||||
|
||||
;; ->v
|
||||
(define ->v (compatible-closure (union-reduction-relations beta_v delta)
|
||||
iswim-grammar
|
||||
M))
|
||||
|
||||
;; :->v
|
||||
(define :->v (context-closure (union-reduction-relations beta_v delta)
|
||||
iswim-grammar
|
||||
E))
|
||||
|
||||
;; :->v+letcc
|
||||
(define :->v+letcc
|
||||
(union-reduction-relations
|
||||
:->v
|
||||
(reduction-relation
|
||||
iswim-grammar
|
||||
|
||||
;; letcc rule:
|
||||
(--> (in-hole E_1 ("letcc" X_1 M_1))
|
||||
(in-hole E_1 ,(iswim-subst (term M_1)
|
||||
(term X_1)
|
||||
`("[" (in-hole E_1 ||) "]"))))
|
||||
|
||||
;; cc rule:
|
||||
(--> (in-hole E ("cc" ("[" (in-hole E_2 ||) "]") V_1))
|
||||
(in-hole E_2 V_1)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Helpers:
|
||||
|
||||
(define (delta*n on Vs)
|
||||
(let ([l (apply-reduction-relation delta `(,on ,@Vs))])
|
||||
(if (null? l)
|
||||
#f
|
||||
(car l))))
|
||||
|
||||
(define (delta*1 o1 V)
|
||||
(delta*n o1 (list V)))
|
||||
|
||||
(define (delta*2 o2 V1 V2)
|
||||
(delta*n o2 (list V1 V2)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Abbreviations:
|
||||
|
||||
(define (if0 test then else)
|
||||
(let ([X (variable-not-in `(,then ,else) 'X)])
|
||||
`(((("iszero" ,test) ("lam" ,X ,then)) ("lam" ,X ,else)) 77)))
|
||||
|
||||
(define true '("lam" x ("lam" y x)))
|
||||
(define false '("lam" x ("lam" y y)))
|
||||
(define boolean-not `("lam" x ((x ,false) ,true)))
|
||||
|
||||
(define mkpair '("lam" x ("lam" y ("lam" s ((s x) y)))))
|
||||
(define fst '("lam" p (p ("lam" x ("lam" y x)))))
|
||||
(define snd '("lam" p (p ("lam" x ("lam" y y)))))
|
||||
|
||||
(define Y_v '("lam" f ("lam" x
|
||||
((("lam" g (f ("lam" x ((g g) x))))
|
||||
("lam" g (f ("lam" x ((g g) x)))))
|
||||
x))))
|
||||
|
||||
(define mksum `("lam" s
|
||||
("lam" x
|
||||
,(if0 'x 0 '("+" x (s ("sub1" x)))))))
|
||||
(define sum `(,Y_v ,mksum))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Exports:
|
||||
|
||||
(provide iswim-grammar)
|
||||
|
||||
(provide/contract (M? (any/c . -> . any/c))
|
||||
(V? (any/c . -> . any/c))
|
||||
(o1? (any/c . -> . any/c))
|
||||
(o2? (any/c . -> . any/c))
|
||||
(on? (any/c . -> . any/c))
|
||||
(k? (any/c . -> . any/c))
|
||||
(env? (any/c . -> . any/c))
|
||||
(cl? (any/c . -> . any/c))
|
||||
(vcl? (any/c . -> . any/c))
|
||||
(iswim-subst (M? symbol? M? . -> . M?))
|
||||
(env-lookup (env? symbol? . -> . (union false/c vcl?)))
|
||||
(env-extend (env? symbol? vcl? . -> . env?))
|
||||
(empty-env env?)
|
||||
(beta_v reduction-relation?)
|
||||
(delta reduction-relation?)
|
||||
(delta*1 (o1? V? . -> . (union false/c V?)))
|
||||
(delta*2 (o2? V? V? . -> . (union false/c V?)))
|
||||
(delta*n (on? (listof V?) . -> . (union false/c V?)))
|
||||
(->v reduction-relation?)
|
||||
(:->v reduction-relation?)
|
||||
(:->v+letcc reduction-relation?)
|
||||
(if0 (M? M? M? . -> . M?))
|
||||
(true M?)
|
||||
(false M?)
|
||||
(boolean-not M?)
|
||||
(mkpair M?)
|
||||
(fst M?)
|
||||
(snd M?)
|
||||
(Y_v M?)
|
||||
(sum M?)))
|
||||
155
collects/redex/examples/letrec.ss
Normal file
155
collects/redex/examples/letrec.ss
Normal file
|
|
@ -0,0 +1,155 @@
|
|||
(module letrec mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "list.ss"))
|
||||
|
||||
(reduction-steps-cutoff 20)
|
||||
|
||||
(define-language lang
|
||||
(p ((store (x v) ...) e))
|
||||
(e (set! x e)
|
||||
(let ((x e)) e)
|
||||
(letrec ((x e)) e)
|
||||
(begin e e ...)
|
||||
(e e)
|
||||
x
|
||||
v)
|
||||
(v (lambda (x) e)
|
||||
number)
|
||||
(x variable)
|
||||
(pc ((store (x v) ...) ec))
|
||||
(ec (ec e)
|
||||
(v ec)
|
||||
(set! variable ec)
|
||||
(let ((x ec)) e)
|
||||
(begin ec e e ...)
|
||||
hole))
|
||||
|
||||
(define substitute
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(set! ,x ,e)
|
||||
(all-vars '())
|
||||
(build (lambda (vars name body) `(set! ,name ,body)))
|
||||
(subterm '() x)
|
||||
(subterm '() e)]
|
||||
[`(let ((,x ,e1)) ,e2)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
|
||||
(subterm '() e1)
|
||||
(subterm (list x) e2)]
|
||||
[`(letrec ((,x ,e1)) ,e2)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars letval body) `(letrec ((,(car vars) ,letval)) ,body)))
|
||||
(subterm (list x) e1)
|
||||
(subterm (list x) e2)]
|
||||
[`(begin ,@(es ...))
|
||||
(all-vars (list))
|
||||
(build (lambda (vars . rest) `(begin ,@rest)))
|
||||
(subterms '() es)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
;; collect : term -> term
|
||||
;; performs a garbage collection on the term `p'
|
||||
(define (collect p)
|
||||
(define (find-unused vars p)
|
||||
(filter (λ (var) (unused? var p))
|
||||
vars))
|
||||
|
||||
(define (unused? var p)
|
||||
(let ([rhss (map cadr (cdar p))]
|
||||
[body (cadr p)])
|
||||
(and (not (free-in? var body))
|
||||
(andmap (λ (rhs) (not (free-in? var rhs)))
|
||||
rhss))))
|
||||
|
||||
(define (free-in? var body)
|
||||
(not (equal? (substitute var (gensym) body)
|
||||
body)))
|
||||
|
||||
(define (remove-unused vars p)
|
||||
`((store ,@(filter (λ (binding) (not (memq (car binding) vars)))
|
||||
(cdar p)))
|
||||
,(cadr p)))
|
||||
|
||||
(let* ([vars (map car (cdar p))]
|
||||
[unused (find-unused vars p)])
|
||||
(cond
|
||||
[(null? unused) p]
|
||||
[else
|
||||
(collect (remove-unused unused p))])))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(==> (in-hole pc_1 (begin v e_1 e_2 ...))
|
||||
(in-hole pc_1 (begin e_1 e_2 ...))
|
||||
begin\ many)
|
||||
|
||||
(==> (in-hole pc_1 (begin e_1))
|
||||
(in-hole pc_1 e_1)
|
||||
begin\ one)
|
||||
|
||||
(==> ((store (x_before v_before) ...
|
||||
(x_i v_i)
|
||||
(x_after v_after) ...)
|
||||
(in-hole ec_1 x_i))
|
||||
((store
|
||||
(x_before v_before) ...
|
||||
(x_i v_i)
|
||||
(x_after v_after) ...)
|
||||
(in-hole ec_1 v_i))
|
||||
deref)
|
||||
|
||||
(==> ((store (x_before v_before) ...
|
||||
(x_i v)
|
||||
(x_after v_after) ...)
|
||||
(in-hole ec_1 (set! x_i v_new)))
|
||||
((store (x_before v_before) ...
|
||||
(x_i v_new)
|
||||
(x_after v_after) ...)
|
||||
(in-hole ec_1 v_new))
|
||||
set!)
|
||||
|
||||
(==> (in-hole pc_1 ((lambda (x_1) e_1) v_1))
|
||||
(in-hole pc_1
|
||||
,(substitute (term x_1) (term v_1) (term e_1)))
|
||||
βv)
|
||||
|
||||
(==> ((store (name the-store any) ...)
|
||||
(in-hole ec_1 (let ((x_1 v_1)) e_1)))
|
||||
,(let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
|
||||
(term
|
||||
((store the-store ... (,new-x v_1))
|
||||
(in-hole ec_1
|
||||
,(substitute (term x_1) new-x (term e_1))))))
|
||||
let)
|
||||
|
||||
(==> (in-hole pc_1 (letrec ((x_1 e_1)) e_2))
|
||||
(in-hole pc_1 (let ((x_1 0)) (begin (set! x_1 e_1) e_2)))
|
||||
letrec)
|
||||
|
||||
where
|
||||
[(==> a b) (--> a ,(collect (term b)))]))
|
||||
|
||||
(define (run e) (traces lang reductions `((store) ,e)))
|
||||
|
||||
(run '(letrec ((f (lambda (x)
|
||||
(letrec ((y (f 1)))
|
||||
2))))
|
||||
(f 3)))
|
||||
|
||||
(run '(letrec ((f (lambda (x)
|
||||
(letrec ((y 1))
|
||||
(f 1)))))
|
||||
(f 3))))
|
||||
60
collects/redex/examples/omega.ss
Normal file
60
collects/redex/examples/omega.ss
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
(module omega mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(reduction-steps-cutoff 10)
|
||||
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
(abort e)
|
||||
x
|
||||
v)
|
||||
(c (v c)
|
||||
(c e)
|
||||
hole)
|
||||
(v call/cc
|
||||
number
|
||||
(lambda (x) e))
|
||||
|
||||
(x (variable-except lambda call/cc abort)))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole c_1 (call/cc v_arg))
|
||||
,(term-let ([v (variable-not-in (term c_1) 'x)])
|
||||
(term (in-hole c_1 (v_arg (lambda (v) (abort (in-hole c_1 v)))))))
|
||||
call/cc)
|
||||
(--> (in-hole c (abort e_1))
|
||||
e_1
|
||||
abort)
|
||||
(--> (in-hole c_1 ((lambda (variable_x) e_body) v_arg))
|
||||
(in-hole c_1 ,(lc-subst (term variable_x) (term v_arg) (term e_body)))
|
||||
βv)))
|
||||
|
||||
(define lc-subst
|
||||
(plt-subst
|
||||
['abort (constant)]
|
||||
['call/cc (constant)]
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(call/cc ,v)
|
||||
(all-vars '())
|
||||
(build (lambda (vars arg) `(call/cc ,arg)))
|
||||
(subterm '() v)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
|
||||
(traces lang reductions '((lambda (x) (x x)) (lambda (x) (x x))))
|
||||
(traces lang reductions '((call/cc call/cc) (call/cc call/cc)))
|
||||
(traces lang reductions '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
|
||||
)
|
||||
169
collects/redex/examples/semaphores.ss
Normal file
169
collects/redex/examples/semaphores.ss
Normal file
|
|
@ -0,0 +1,169 @@
|
|||
#|
|
||||
|
||||
semaphores make things much more predictable...
|
||||
|
||||
|#
|
||||
|
||||
(module semaphores mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
(define-language lang
|
||||
(p ((store (variable v) ...)
|
||||
(semas (variable sema-count) ...)
|
||||
(threads e ...)))
|
||||
(sema-count number
|
||||
none)
|
||||
(e (set! variable e)
|
||||
(begin e ...)
|
||||
(semaphore variable)
|
||||
(semaphore-wait e)
|
||||
(semaphore-post e)
|
||||
(lambda (variable) e)
|
||||
(e e)
|
||||
variable
|
||||
(list e ...)
|
||||
(cons e e)
|
||||
number
|
||||
(void))
|
||||
(p-ctxt ((store (variable v) ...)
|
||||
(semas (variable sema-count) ...)
|
||||
(threads e ... e-ctxt e ...)))
|
||||
(e-ctxt (e-ctxt e)
|
||||
(v e-ctxt)
|
||||
(cons e-ctxt e)
|
||||
(cons v e-ctxt)
|
||||
(list v ... e-ctxt e ...)
|
||||
(set! variable e-ctxt)
|
||||
(begin e-ctxt e ...)
|
||||
(semaphore-wait e-ctxt)
|
||||
(semaphore-post e-ctxt)
|
||||
hole)
|
||||
(v (semaphore variable)
|
||||
(lambda (variable) e)
|
||||
(list v ...)
|
||||
number
|
||||
(void)))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole (name c p-ctxt) (begin v e_1 e_2 e_rest ...))
|
||||
(in-hole c (begin e_1 e_2 e_rest ...)))
|
||||
(--> (in-hole (name c p-ctxt) (cons v_1 (list v_2s ...)))
|
||||
(in-hole c (list v_1 v_2s ...)))
|
||||
(--> (in-hole (name c p-ctxt) (begin v e_1))
|
||||
(in-hole c e_1))
|
||||
(--> (in-hole (name c p-ctxt) (begin v_1))
|
||||
(in-hole c v_1))
|
||||
(--> ((store
|
||||
(variable_before v_before) ...
|
||||
((name x variable) (name v v))
|
||||
(variable_after v_after) ...)
|
||||
(name semas any)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole (name c e-ctxt) (name x variable))
|
||||
e_after ...))
|
||||
((store
|
||||
(variable_before v_before) ...
|
||||
(x v)
|
||||
(variable_after v_after) ...)
|
||||
semas
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole c v)
|
||||
e_after ...)))
|
||||
(--> ((store (variable_before v_before) ...
|
||||
(variable_i v)
|
||||
(variable_after v_after) ...)
|
||||
(name semas any)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole (name c e-ctxt) (set! variable_i v_new))
|
||||
e_after ...))
|
||||
((store (variable_before v_before) ...
|
||||
(variable_i v_new)
|
||||
(variable_after v_after) ...)
|
||||
semas
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole c (void))
|
||||
e_after ...)))
|
||||
(--> ((name store any)
|
||||
(semas
|
||||
(variable_before v_before) ...
|
||||
(variable_sema number_n)
|
||||
(variable_after v_after) ...)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole (name c e-ctxt) (semaphore-wait (semaphore variable_sema)))
|
||||
e_after ...))
|
||||
(store
|
||||
(semas
|
||||
(variable_before v_before) ...
|
||||
(variable_sema ,(if (= (term number_n) 1)
|
||||
(term none)
|
||||
(- (term number_n) 1)))
|
||||
(variable_after v_after) ...)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole c (void))
|
||||
e_after ...)))
|
||||
(--> ((name store any)
|
||||
(semas
|
||||
(variable_before v_before) ...
|
||||
(variable_sema number_n)
|
||||
(variable_after v_after) ...)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole (name c e-ctxt) (semaphore-post (semaphore variable_sema)))
|
||||
e_after ...))
|
||||
(store
|
||||
(semas
|
||||
(variable_before v_before) ...
|
||||
(variable_sema ,(+ (term number_n) 1))
|
||||
(variable_after v_after) ...)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole c (void))
|
||||
e_after ...)))
|
||||
|
||||
(--> ((name store any)
|
||||
(semas
|
||||
(variable_before v_before) ...
|
||||
(variable_sema none)
|
||||
(variable_after v_after) ...)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole (name c e-ctxt) (semaphore-post (semaphore variable_sema)))
|
||||
e_after ...))
|
||||
(store
|
||||
(semas
|
||||
(variable_before v_before) ...
|
||||
(variable_sema 1)
|
||||
(variable_after v_after) ...)
|
||||
(threads
|
||||
e_before ...
|
||||
(in-hole c (void))
|
||||
e_after ...)))))
|
||||
|
||||
(stepper lang
|
||||
reductions
|
||||
`((store (y (list)))
|
||||
(semas)
|
||||
(threads (set! y (cons 1 y))
|
||||
(set! y (cons 2 y)))))
|
||||
|
||||
(stepper lang
|
||||
reductions
|
||||
`((store (y (list)))
|
||||
(semas (x 1))
|
||||
(threads (begin (semaphore-wait (semaphore x))
|
||||
(set! y (cons 1 y))
|
||||
(semaphore-post (semaphore x)))
|
||||
(begin (semaphore-wait (semaphore x))
|
||||
(set! y (cons 2 y))
|
||||
(semaphore-post (semaphore x)))))))
|
||||
92
collects/redex/examples/subject-reduction.ss
Normal file
92
collects/redex/examples/subject-reduction.ss
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
(module subject-reduction mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/gui)
|
||||
(planet robby/redex:5/subst)
|
||||
(lib "plt-match.ss"))
|
||||
|
||||
(reduction-steps-cutoff 10)
|
||||
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
(abort e)
|
||||
x
|
||||
v)
|
||||
(x (variable-except lambda call/cc abort))
|
||||
(c (v c)
|
||||
(c e)
|
||||
hole)
|
||||
(v call/cc
|
||||
number
|
||||
(lambda (x t) e))
|
||||
(t num
|
||||
(t -> t)))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole c_1 (call/cc v_arg))
|
||||
,(term-let ([v (variable-not-in (term c_1) 'x)])
|
||||
(term
|
||||
(in-hole c_1 (v_arg (lambda (v) (abort (in-hole c_1 v)))))))
|
||||
call/cc)
|
||||
(--> (in-hole c (abort e_1))
|
||||
e_1
|
||||
abort)
|
||||
|
||||
;; this rules calls subst with the wrong arguments, which is caught by the example below.
|
||||
(--> (in-hole c_1 ((lambda (x_format t_1) e_body) v_actual))
|
||||
(in-hole c_1 ,(lc-subst (term x_format) (term e_body) (term v_actual)))
|
||||
βv)))
|
||||
|
||||
(define lc-subst
|
||||
(plt-subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x ,t) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(call/cc ,v)
|
||||
(all-vars '())
|
||||
(build (lambda (vars arg) `(call/cc ,arg)))
|
||||
(subterm '() v)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
(define (type-check term)
|
||||
(let/ec k
|
||||
(let loop ([term term]
|
||||
[env '()])
|
||||
(match term
|
||||
[(? symbol?)
|
||||
(let ([l (assoc term env)])
|
||||
(if l
|
||||
(cdr l)
|
||||
(k #f)))]
|
||||
[(? number?) 'num]
|
||||
[`(lambda (,x ,t) ,b)
|
||||
(let ([body (loop b (cons (cons x t) env))])
|
||||
`(,t -> ,body))]
|
||||
[`(,e1 ,e2)
|
||||
(let ([t1 (loop e1 env)]
|
||||
[t2 (loop e2 env)])
|
||||
(match t1
|
||||
[`(,td -> ,tr)
|
||||
(if (equal? td t2)
|
||||
tr
|
||||
(k #f))]
|
||||
[else (k #f)]))]))))
|
||||
|
||||
(define (pred term1)
|
||||
(let ([t1 (type-check term1)])
|
||||
(lambda (term2)
|
||||
(and t1
|
||||
(equal? (type-check term2) t1)))))
|
||||
|
||||
(define (show term)
|
||||
(traces/pred lang reductions (list term) (pred term)))
|
||||
|
||||
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x)))))
|
||||
117
collects/redex/examples/threads.ss
Normal file
117
collects/redex/examples/threads.ss
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
(module threads mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(planet robby/redex:5/gui)
|
||||
(lib "plt-match.ss"))
|
||||
|
||||
(reduction-steps-cutoff 100)
|
||||
|
||||
(define-language threads
|
||||
(p ((store (x v) ...) (threads e ...)))
|
||||
(e (set! x e)
|
||||
(let ((x e)) e)
|
||||
(e e)
|
||||
x
|
||||
v
|
||||
(+ e e))
|
||||
(v (lambda (x) e)
|
||||
number)
|
||||
(x variable)
|
||||
(pc ((store (x v) ...) tc))
|
||||
(tc (threads e ... ec e ...))
|
||||
(ec (ec e) (v ec) (set! variable ec) (let ((x ec)) e) (+ ec e) (+ v ec) hole))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
threads
|
||||
(--> (in-hole pc_1 (+ number_1 number_2))
|
||||
(in-hole pc_1 ,(+ (term number_1) (term number_2)))
|
||||
sum)
|
||||
|
||||
(--> ((store
|
||||
(name befores (x v)) ...
|
||||
(x_i v_i)
|
||||
(name afters (x v)) ...)
|
||||
(in-hole tc_1 x_i))
|
||||
((store
|
||||
befores ...
|
||||
(x_i v_i)
|
||||
afters ...)
|
||||
(in-hole tc_1 v_i))
|
||||
deref)
|
||||
|
||||
(--> ((store (x_1 v_1) ... (x_i v) (x_2 v_2) ...)
|
||||
(in-hole tc_1 (set! x_i v_new)))
|
||||
((store (x_1 v_1) ... (x_i v_new) (x_2 v_2) ...)
|
||||
(in-hole tc_1 v_new))
|
||||
set!)
|
||||
|
||||
(--> (in-hole pc_1 ((lambda (x_1) e_1) v_1))
|
||||
(in-hole pc_1 ,(substitute (term x_1) (term v_1) (term e_1)))
|
||||
app)
|
||||
|
||||
(--> ((store (name the-store any) ...)
|
||||
(in-hole tc_1 (let ((x_1 v_1)) e_1)))
|
||||
(term-let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
|
||||
(term
|
||||
((store the-store ... (new-x v_1))
|
||||
(in-hole tc_1 ,(substitute (term x_1) (term new-x) (term e_1))))))
|
||||
let)))
|
||||
|
||||
(define substitute
|
||||
(plt-subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(set! ,x ,e)
|
||||
(all-vars '())
|
||||
(build (lambda (vars name body) `(set! ,name ,body)))
|
||||
(subterm '() x)
|
||||
(subterm '() e)]
|
||||
[`(let ((,x ,e1)) ,e2)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
|
||||
(subterm '() e1)
|
||||
(subterm (list x) e2)]
|
||||
[`(+ ,e1 ,e2)
|
||||
(all-vars '())
|
||||
(build (lambda (vars e1 e2) `(+ ,e1 ,e2)))
|
||||
(subterm '() e1)
|
||||
(subterm '() e2)]
|
||||
[`(,f ,x)
|
||||
(all-vars '())
|
||||
(build (lambda (vars f x) `(,f ,x)))
|
||||
(subterm '() f)
|
||||
(subterm '() x)]))
|
||||
|
||||
(define (run es) (traces threads reductions `((store) (threads ,@es))))
|
||||
(provide run)
|
||||
|
||||
(define (count x)
|
||||
(match x
|
||||
[`(set! ,x ,e) (+ 1 (count e))]
|
||||
[(? symbol?) 1]
|
||||
[(? number?) 0]
|
||||
[`(+ ,e1 ,e2) (+ 1 (count e1) (count e2))]))
|
||||
|
||||
;; use a pretty-printer that just summaizes the terms, showing the depth of each thread.
|
||||
(traces threads reductions
|
||||
'((store (x 1))
|
||||
(threads
|
||||
(set! x (+ x -1))
|
||||
(set! x (+ x 1))))
|
||||
|
||||
(lambda (exp)
|
||||
(match exp
|
||||
[`((store (x ,x)) (threads ,t1 ,t2))
|
||||
(format "~a ~a ~a" x (count t1) (count t2))])))
|
||||
|
||||
(parameterize ([initial-char-width 16])
|
||||
(stepper threads reductions '((store) (threads
|
||||
(+ 1 1)
|
||||
(+ 1 1)
|
||||
(+ 1 1)))))
|
||||
)
|
||||
87
collects/redex/examples/types.ss
Normal file
87
collects/redex/examples/types.ss
Normal file
|
|
@ -0,0 +1,87 @@
|
|||
(module types mzscheme
|
||||
(require (planet robby/redex:5/reduction-semantics)
|
||||
(planet robby/redex:5/subst)
|
||||
(planet robby/redex:5/gui))
|
||||
|
||||
(reduction-steps-cutoff 10)
|
||||
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
x
|
||||
number
|
||||
(lambda (x t) e)
|
||||
(if e e e)
|
||||
(= e e)
|
||||
(-> e e)
|
||||
num
|
||||
bool)
|
||||
(c (t c)
|
||||
(c e)
|
||||
(-> t c)
|
||||
(-> c e)
|
||||
(= t c)
|
||||
(= c e)
|
||||
(if c e e)
|
||||
(if t c e)
|
||||
(if t t c)
|
||||
hole)
|
||||
(x (variable-except lambda -> if =))
|
||||
(t num bool (-> t t)))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(r--> number num)
|
||||
|
||||
(r--> (lambda (x_1 t_1) e_body)
|
||||
(-> t_1 ,(lc-subst (term x_1)
|
||||
(term t_1)
|
||||
(term e_body))))
|
||||
|
||||
(r--> ((-> t_1 t_2) t_1) t_2)
|
||||
|
||||
(e--> (side-condition ((-> t_1 t) t_2)
|
||||
(not (equal? (term t_1) (term t_2))))
|
||||
,(format "app: domain error ~s and ~s" (term t_1) (term t_2)))
|
||||
|
||||
(e--> (num t_1)
|
||||
,(format "app: non function error ~s" (term t_1)))
|
||||
|
||||
(r--> (if bool t_1 t_1) t_1)
|
||||
(e--> (side-condition (if bool t_1 t_2)
|
||||
(not (equal? (term t_1) (term t_2))))
|
||||
,(format "if: then and else clause mismatch ~s and ~s" (term t_1) (term t_2)))
|
||||
(e--> (side-condition (if t_1 t t)
|
||||
(not (equal? (term t_1) 'bool)))
|
||||
,(format "if: test not boolean ~s" (term t_1)))
|
||||
|
||||
(r--> (= num num) bool)
|
||||
(e--> (side-condition (= t_1 t_2)
|
||||
(or (not (equal? (term t_1) 'num))
|
||||
(not (equal? (term t_2) 'num))))
|
||||
,(format "=: not comparing numbers ~s and ~s" (term t_1) (term t_2)))
|
||||
|
||||
where
|
||||
|
||||
[(r--> a b) (--> (in-hole c_1 a) (in-hole c_1 b))]
|
||||
[(e--> a b) (--> (in-hole c a) b)]))
|
||||
|
||||
(define lc-subst
|
||||
(subst
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(lambda (,x ,t) ,b)
|
||||
(all-vars (list x))
|
||||
(build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
|
||||
(subterm (list x) b)]
|
||||
[`(,f ,@(xs ...))
|
||||
(all-vars '())
|
||||
(build (lambda (vars f . xs) `(,f ,@xs)))
|
||||
(subterm '() f)
|
||||
(subterms '() xs)]))
|
||||
|
||||
(traces lang reductions
|
||||
'((lambda (x num) (lambda (y num) (if (= x y) 0 x))) 1))
|
||||
(traces lang reductions
|
||||
'((lambda (x num) (lambda (y num) (if (= x y) 0 (lambda (x num) x)))) 1))
|
||||
)
|
||||
252
collects/redex/generator.ss
Normal file
252
collects/redex/generator.ss
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
#|
|
||||
|
||||
An attempt to automatically test reduction systems;
|
||||
this generates terms from a language automatically.
|
||||
|
||||
|#
|
||||
|
||||
(module generator mzscheme
|
||||
(require "private/matcher.ss")
|
||||
|
||||
(provide lang->generator-table
|
||||
for-each-generated
|
||||
for-each-generated/size)
|
||||
|
||||
(define (lang->generator-table lang
|
||||
nums
|
||||
vars
|
||||
strs
|
||||
skip-kws
|
||||
cache-limit)
|
||||
|
||||
;; -------------------- Cache implementation --------------------
|
||||
;; Cache is currently disabled. It's not clear that it's useful.
|
||||
(define (cache-small gen) gen)
|
||||
|
||||
;; -------------------- Build table --------------------
|
||||
;; The `gens' table maps non-terminal symbols to
|
||||
;; generator functions. A generator function conumes:
|
||||
;; * the min acceptable size of a generated element
|
||||
;; * the max acceptable size of a generated element
|
||||
;; * a sucess continuation proc that accepts
|
||||
;; - the generated value
|
||||
;; - the value's size
|
||||
;; - a generator proc that produces the next value;
|
||||
;; this proc expects to be given the same min, max,
|
||||
;; and fail continuation proc as before
|
||||
;; * a failure continuation thunk
|
||||
;;
|
||||
(let ([nts (compiled-lang-lang lang)]
|
||||
[nt-map (make-hash-table)])
|
||||
;; nt-map tells us which symbols are non-terminals; it also
|
||||
;; provides conservative min-size and max-size thunks that are
|
||||
;; refined as table generation proceeds
|
||||
(for-each (lambda (nt) (hash-table-put! nt-map (nt-name nt)
|
||||
(cons (lambda () 1)
|
||||
(lambda () +inf.0))))
|
||||
nts)
|
||||
;; gens is the main hash table
|
||||
(let ([gens (make-hash-table)]
|
||||
[atomic-alts (lambda (l size)
|
||||
(values
|
||||
(lambda (min-size max-size result-k fail-k)
|
||||
(let loop ([l l][result-k result-k][max-size max-size][fail-k fail-k])
|
||||
(if (<= min-size size max-size)
|
||||
(if (null? l)
|
||||
(fail-k)
|
||||
(result-k (car l)
|
||||
size
|
||||
(lambda (s xs result-k fail-k)
|
||||
(loop (cdr l) result-k xs fail-k))))
|
||||
(fail-k))))
|
||||
(lambda () size)
|
||||
(lambda () size)))]
|
||||
[to-do nts])
|
||||
(letrec ([make-gen/get-size
|
||||
(lambda (p)
|
||||
(cond
|
||||
[(hash-table-get nt-map p (lambda () #f))
|
||||
=> (lambda (get-sizes)
|
||||
(values
|
||||
(lambda (min-size max-size result-k fail-k)
|
||||
((hash-table-get gens p) min-size max-size result-k fail-k))
|
||||
(car get-sizes)
|
||||
(cdr get-sizes)))]
|
||||
[(eq? 'number p) (atomic-alts nums 1)]
|
||||
[(eq? 'string p) (atomic-alts strs 1)]
|
||||
[(eq? 'any p) (atomic-alts (append nums strs vars) 1)]
|
||||
[(or (eq? 'variable p)
|
||||
(and (pair? p)
|
||||
(eq? (car p) 'variable-except)))
|
||||
(atomic-alts vars 1)]
|
||||
[(symbol? p) ; not a non-terminal, because we checked above
|
||||
(if (memq p skip-kws)
|
||||
(values
|
||||
(lambda (min-size max-size result-k fail-k)
|
||||
(fail-k))
|
||||
(lambda () +inf.0)
|
||||
(lambda () -1))
|
||||
(atomic-alts (list p) 0))]
|
||||
[(null? p) (atomic-alts (list null) 0)]
|
||||
[(and (pair? p)
|
||||
(or (not (pair? (cdr p)))
|
||||
(not (eq? '... (cadr p)))))
|
||||
(make-pair-gen/get-size p cons)]
|
||||
[(and (pair? p) (pair? (cdr p)) (eq? '... (cadr p)))
|
||||
(let-values ([(just-rest just-rest-min-size just-rest-max-size)
|
||||
(make-gen/get-size (cddr p))]
|
||||
[(both both-min-size both-max-size)
|
||||
(make-pair-gen/get-size (cons (kleene+ (car p)) (cddr p)) append)])
|
||||
(values
|
||||
(lambda (min-size max-size result-k fail-k)
|
||||
(let loop ([both both][result-k result-k][max-size max-size][fail-k fail-k])
|
||||
(both min-size max-size
|
||||
(lambda (v size next-both)
|
||||
(result-k v size
|
||||
(lambda (ns xs result-k fail-k)
|
||||
(loop next-both result-k xs fail-k))))
|
||||
(lambda ()
|
||||
(just-rest min-size max-size result-k fail-k)))))
|
||||
just-rest-min-size
|
||||
(lambda () +inf.0)))]
|
||||
[else
|
||||
(error 'make-gen "unrecognized pattern: ~e" p)]))]
|
||||
[make-pair-gen/get-size
|
||||
(lambda (p combiner)
|
||||
(let*-values ([(first first-min-size first-max-size)
|
||||
(make-gen/get-size (car p))]
|
||||
[(rest rest-min-size rest-max-size)
|
||||
(make-gen/get-size (cdr p))]
|
||||
[(this-min-size) (let ([v #f])
|
||||
(lambda ()
|
||||
(unless v
|
||||
(set! v (+ (first-min-size)
|
||||
(rest-min-size))))
|
||||
v))]
|
||||
[(this-max-size) (let ([v #f])
|
||||
(lambda ()
|
||||
(unless v
|
||||
(set! v (+ (first-max-size)
|
||||
(rest-max-size))))
|
||||
v))])
|
||||
(values
|
||||
(cache-small
|
||||
(lambda (min-size max-size result-k fail-k)
|
||||
(if (min-size . > . (this-max-size))
|
||||
(fail-k)
|
||||
(let rloop ([rest rest][result-k result-k][max-size max-size][fail-k fail-k][failed-size +inf.0])
|
||||
(if (max-size . < . (this-min-size))
|
||||
(fail-k)
|
||||
(rest
|
||||
(max 0 (- min-size (first-max-size)))
|
||||
(min (sub1 failed-size) (- max-size (first-min-size)))
|
||||
(lambda (rest rest-size next-rest)
|
||||
(if (rest-size . >= . failed-size)
|
||||
(rloop next-rest result-k max-size fail-k failed-size)
|
||||
(let floop ([first first]
|
||||
[result-k result-k]
|
||||
[max-size max-size]
|
||||
[fail-k fail-k]
|
||||
[first-fail-k (lambda ()
|
||||
(rloop next-rest result-k max-size fail-k rest-size))])
|
||||
(first (max 0 (- min-size rest-size))
|
||||
(- max-size rest-size)
|
||||
(lambda (first first-size next-first)
|
||||
(result-k
|
||||
(combiner first rest)
|
||||
(+ first-size rest-size)
|
||||
(lambda (ns xs result-k fail-k)
|
||||
(floop next-first result-k xs fail-k
|
||||
(lambda ()
|
||||
(rloop next-rest result-k xs fail-k failed-size))))))
|
||||
first-fail-k))))
|
||||
fail-k))))))
|
||||
this-min-size
|
||||
this-max-size)))]
|
||||
[kleene+ (lambda (p)
|
||||
(let ([n (gensym)])
|
||||
(hash-table-put! nt-map n (cons (lambda () 1)
|
||||
(lambda () +inf.0)))
|
||||
(set! to-do (cons (make-nt
|
||||
n
|
||||
(list (make-rhs (cons p '()))
|
||||
(make-rhs (cons p n))))
|
||||
to-do))
|
||||
n))])
|
||||
(let to-do-loop ([nts (reverse to-do)])
|
||||
(set! to-do null)
|
||||
(for-each (lambda (nt)
|
||||
(hash-table-put!
|
||||
gens
|
||||
(nt-name nt)
|
||||
(let* ([gens+sizes
|
||||
(map (lambda (rhs)
|
||||
(let-values ([(gen get-min-size get-max-size)
|
||||
(make-gen/get-size
|
||||
(rhs-pattern rhs))])
|
||||
(cons gen (cons get-min-size get-max-size))))
|
||||
(nt-rhs nt))]
|
||||
[get-min-size
|
||||
(let ([get-min-sizes (map cadr gens+sizes)])
|
||||
(let ([v #f])
|
||||
(lambda ()
|
||||
(unless v
|
||||
(set! v (add1
|
||||
(apply min (map (lambda (gs) (gs))
|
||||
get-min-sizes)))))
|
||||
v)))]
|
||||
[get-max-size
|
||||
(let ([get-max-sizes (map cddr gens+sizes)])
|
||||
(let ([v #f])
|
||||
(lambda ()
|
||||
(unless v
|
||||
(set! v (add1
|
||||
(apply max (map (lambda (gs) (gs))
|
||||
get-max-sizes)))))
|
||||
v)))])
|
||||
(hash-table-put! nt-map (nt-name nt)
|
||||
(cons get-min-size get-max-size))
|
||||
(cache-small
|
||||
(lambda (min-size max-size result-k fail-k)
|
||||
(if (min-size . > . (get-max-size))
|
||||
(fail-k)
|
||||
(let loop ([l (map car gens+sizes)][result-k result-k][max-size max-size][fail-k fail-k])
|
||||
(if (max-size . < . (get-min-size))
|
||||
(fail-k)
|
||||
(if (null? l)
|
||||
(fail-k)
|
||||
(let iloop ([alt-next (car l)]
|
||||
[result-k result-k]
|
||||
[max-size max-size]
|
||||
[fail-k fail-k])
|
||||
(alt-next
|
||||
(max 0 (sub1 min-size))
|
||||
(sub1 max-size)
|
||||
(lambda (alt a-size alt-next)
|
||||
(result-k
|
||||
alt
|
||||
(add1 a-size)
|
||||
(lambda (ns xs result-k fail-k)
|
||||
(iloop alt-next result-k xs fail-k))))
|
||||
(lambda ()
|
||||
(loop (cdr l) result-k max-size fail-k)))))))))))))
|
||||
nts)
|
||||
(unless (null? to-do)
|
||||
(to-do-loop to-do))))
|
||||
gens)))
|
||||
|
||||
(define (for-each-generated/size proc gens min-size max-size nonterm)
|
||||
(let ([gen (hash-table-get gens nonterm)])
|
||||
(let loop ([gen gen])
|
||||
(gen
|
||||
min-size
|
||||
max-size
|
||||
(lambda (val z1 gen-next)
|
||||
(proc val z1)
|
||||
(loop gen-next))
|
||||
void))))
|
||||
|
||||
(define (for-each-generated proc gens nonterm)
|
||||
(let loop ([i 0])
|
||||
(for-each-generated/size proc gens i i nonterm)
|
||||
(loop (add1 i)))))
|
||||
64
collects/redex/gui.ss
Normal file
64
collects/redex/gui.ss
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
;; should cache the count of new snips -- dont
|
||||
;; use `count-snips'; use something associated with the
|
||||
;; equal hash-table
|
||||
|
||||
#lang scheme/base
|
||||
|
||||
(require "private/stepper.ss"
|
||||
"private/traces.ss"
|
||||
"private/matcher.ss"
|
||||
"private/reduction-semantics.ss"
|
||||
"private/size-snip.ss"
|
||||
scheme/contract
|
||||
scheme/class
|
||||
scheme/gui/base)
|
||||
|
||||
(define pp-contract
|
||||
(or/c (-> any/c string?)
|
||||
(-> any/c output-port? number? (is-a?/c text%) any)))
|
||||
|
||||
(define ((reduction-sequence? red) terms)
|
||||
(let loop ([term (car terms)]
|
||||
[terms (cdr terms)])
|
||||
(or (null? terms)
|
||||
(and (member (car terms) (apply-reduction-relation red term))
|
||||
(loop (car terms)
|
||||
(cdr terms))))))
|
||||
|
||||
(provide/contract
|
||||
[traces (->* (reduction-relation?
|
||||
any/c)
|
||||
(#:multiple?
|
||||
boolean?
|
||||
#:pred (or/c (any/c . -> . any)
|
||||
(any/c term-node? . -> . any))
|
||||
#:pp pp-contract
|
||||
#:colors (listof any/c))
|
||||
any)]
|
||||
|
||||
[term-node? (-> any/c boolean?)]
|
||||
[term-node-parents (-> term-node? (listof term-node?))]
|
||||
[term-node-children (-> term-node? (listof term-node?))]
|
||||
[term-node-labels (-> term-node? (listof (or/c false/c string?)))]
|
||||
[term-node-set-red! (-> term-node? boolean? void?)]
|
||||
[term-node-set-color! (-> term-node?
|
||||
(or/c string? (is-a?/c color%) false/c)
|
||||
void?)]
|
||||
[term-node-expr (-> term-node? any)]
|
||||
|
||||
[stepper
|
||||
(->* (reduction-relation?
|
||||
any/c)
|
||||
(pp-contract)
|
||||
void?)]
|
||||
[stepper/seed
|
||||
(->* (reduction-relation?
|
||||
(cons/c any/c (listof any/c)))
|
||||
(pp-contract)
|
||||
void?)])
|
||||
|
||||
|
||||
(provide reduction-steps-cutoff initial-font-size initial-char-width
|
||||
dark-pen-color light-pen-color dark-brush-color light-brush-color
|
||||
dark-text-color light-text-color
|
||||
default-pretty-printer)
|
||||
10
collects/redex/info.ss
Normal file
10
collects/redex/info.ss
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "PLT Redex")
|
||||
(define doc.txt "doc.txt")
|
||||
(define homepage
|
||||
"http://people.cs.uchicago.edu/~robby/plt-redex/")
|
||||
(define blurb
|
||||
(list '(div "A domain-specific language for context-sensitive reduction semantics. Put in a specification and get out a stepper.")))
|
||||
(define required-core-version "371.4")
|
||||
(define primary-file "reduction-semantics.ss")
|
||||
(define categories '(metaprogramming)))
|
||||
88
collects/redex/pict.ss
Normal file
88
collects/redex/pict.ss
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/contract
|
||||
"private/pict.ss"
|
||||
"private/core-layout.ss"
|
||||
"private/loc-wrapper.ss"
|
||||
"reduction-semantics.ss"
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "mrpict.ss" "texpict"))
|
||||
|
||||
(provide/contract
|
||||
[reduction-relation->pict
|
||||
(->* (reduction-relation?)
|
||||
((or/c false/c (listof (or/c string? symbol?))))
|
||||
pict?)]
|
||||
[reduction-relation->ps
|
||||
(->* (reduction-relation?
|
||||
(or/c string? path?))
|
||||
((or/c false/c (listof (or/c string? symbol?))))
|
||||
void?)]
|
||||
[language->pict
|
||||
(->* (compiled-lang?)
|
||||
((or/c false/c (cons/c symbol? (listof symbol?))))
|
||||
pict?)]
|
||||
[language->ps
|
||||
(->* (compiled-lang?
|
||||
(or/c path? string?))
|
||||
((or/c false/c (cons/c symbol? (listof symbol?))))
|
||||
void?)]
|
||||
[extend-language-show-union (parameter/c boolean?)])
|
||||
|
||||
; syntax
|
||||
(provide metafunction->pict
|
||||
metafunction->ps)
|
||||
|
||||
(provide/contract
|
||||
[current-text (parameter/c (-> string? text-style/c number? pict?))])
|
||||
|
||||
(provide/contract
|
||||
[label-style (parameter/c text-style/c)]
|
||||
[literal-style (parameter/c text-style/c)]
|
||||
[metafunction-style (parameter/c text-style/c)]
|
||||
[default-style (parameter/c text-style/c)]
|
||||
[non-terminal-style (parameter/c text-style/c)]
|
||||
[non-terminal-subscript-style (parameter/c text-style/c)]
|
||||
[linebreaks (parameter/c (or/c false/c (listof boolean?)))]
|
||||
[curly-quotes-for-strings (parameter/c boolean?)])
|
||||
|
||||
(provide/contract
|
||||
[rule-pict-style
|
||||
(parameter/c (symbols 'compact-vertical
|
||||
'vertical
|
||||
'vertical-overlapping-side-conditions
|
||||
'horizontal))]
|
||||
[arrow-space (parameter/c natural-number/c)]
|
||||
[label-space (parameter/c natural-number/c)]
|
||||
[metafunction-pict-style
|
||||
(parameter/c (symbols 'left-right
|
||||
'up-down))])
|
||||
|
||||
(provide/contract
|
||||
[label-font-size (parameter/c (and/c (between/c 1 255) integer?))]
|
||||
[default-font-size (parameter/c (and/c (between/c 1 255) integer?))]
|
||||
[metafunction-font-size (parameter/c (and/c (between/c 1 255) integer?))]
|
||||
[reduction-relation-rule-separation (parameter/c (and/c integer? positive? exact?))])
|
||||
|
||||
(provide
|
||||
build-lw
|
||||
lw
|
||||
lw?
|
||||
lw-e
|
||||
lw-line
|
||||
lw-line-span
|
||||
lw-column
|
||||
lw-column-span)
|
||||
|
||||
(provide/contract
|
||||
[just-before (-> (or/c pict? string? symbol?) lw? lw?)]
|
||||
[just-after (-> (or/c pict? string? symbol?) lw? lw?)])
|
||||
(provide with-unquote-rewriter
|
||||
with-compound-rewriter
|
||||
with-atomic-rewriter)
|
||||
|
||||
(provide/contract
|
||||
[set-arrow-pict! (-> symbol? (-> pict?) void?)]
|
||||
|
||||
[lw->pict
|
||||
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)])
|
||||
122
collects/redex/private/arrow.ss
Normal file
122
collects/redex/private/arrow.ss
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
(module arrow mzscheme
|
||||
(require (lib "mrpict.ss" "texpict")
|
||||
(lib "utils.ss" "texpict")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
[make-arrow-pict
|
||||
(-> string?
|
||||
(symbols 'curvy 'straight 'straight-double)
|
||||
symbol?
|
||||
number?
|
||||
(-> pict?))])
|
||||
|
||||
(define (make-arrow-pict sample-str style font-family font-size)
|
||||
(let ([ans #f])
|
||||
(λ ()
|
||||
(or ans
|
||||
(begin
|
||||
(set! ans (raw-make-arrow-pict sample-str style font-family font-size))
|
||||
ans)))))
|
||||
|
||||
(define (raw-make-arrow-pict sample-str style font-family font-size)
|
||||
(let-values ([(w h d a) (send (dc-for-text-size) get-text-extent sample-str
|
||||
(send the-font-list
|
||||
find-or-create-font
|
||||
font-size
|
||||
font-family
|
||||
'normal
|
||||
'normal))])
|
||||
(let* ([ps-pen-width-factor 0.042] ;; factor of the height to get the pen width
|
||||
[screen-pen-width-factor .08]
|
||||
[line-pos (+ a (/ (- h a) 2))]
|
||||
[head-width (/ w 5)]
|
||||
[head-height (* (- h a) 9/16)]
|
||||
[path (and (eq? style 'curvy)
|
||||
(let* ([b (blank w (- h a d) d)]
|
||||
[a-sz (* head-width 1)]
|
||||
[p (new dc-path%)]
|
||||
[inc (/ (- w head-width) 3)])
|
||||
(send p move-to 0 line-pos)
|
||||
(let ([y (- line-pos (/ a-sz 2))])
|
||||
(send p curve-to
|
||||
0 line-pos
|
||||
(/ inc 2) y
|
||||
inc y)
|
||||
(let ([y2 (+ line-pos (/ a-sz 2))])
|
||||
(send p curve-to
|
||||
(* 3/2 inc) y
|
||||
(* 3/2 inc) y2
|
||||
(* 2 inc) y2)
|
||||
(send p curve-to
|
||||
(* 5/2 inc) y2
|
||||
(* 5/2 inc) line-pos
|
||||
(* 3 inc) line-pos)
|
||||
(send p line-to w line-pos)))
|
||||
p))])
|
||||
(inset
|
||||
(dc
|
||||
(λ (dc dx dy)
|
||||
(let ([old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)]
|
||||
[pen-width-factor
|
||||
(if (or (is-a? dc printer-dc%)
|
||||
(is-a? dc post-script-dc%))
|
||||
ps-pen-width-factor
|
||||
screen-pen-width-factor)])
|
||||
(send dc set-pen (send old-pen get-color) (* h pen-width-factor) 'solid)
|
||||
|
||||
;; main line of arrow
|
||||
(case style
|
||||
[(curvy)
|
||||
(send dc draw-path path dx dy)]
|
||||
[(straight)
|
||||
(send dc draw-line
|
||||
dx
|
||||
(+ dy line-pos)
|
||||
(+ dx w)
|
||||
(+ dy line-pos))]
|
||||
[(straight-double)
|
||||
(send dc draw-line
|
||||
dx
|
||||
(+ dy line-pos -1)
|
||||
(+ dx w -2)
|
||||
(+ dy line-pos -1))
|
||||
(send dc draw-line
|
||||
dx
|
||||
(+ dy line-pos 1)
|
||||
(+ dx w -2)
|
||||
(+ dy line-pos 1))])
|
||||
|
||||
(unless (eq? style 'straight-double)
|
||||
;; when a single line arrow, make the arrow head's lines a tiny bit thinner
|
||||
(send dc set-pen (send old-pen get-color) (* h pen-width-factor .8) 'solid))
|
||||
|
||||
;; upper line of arrowhead
|
||||
(send dc draw-spline
|
||||
(+ dx w)
|
||||
(+ dy line-pos)
|
||||
|
||||
(+ dx w (- head-width) (* head-width 1/5))
|
||||
(+ dy line-pos (- (* head-height 4/16)))
|
||||
|
||||
(+ dx w (- head-width))
|
||||
(+ dy line-pos (- (/ head-height 2))))
|
||||
|
||||
;; lower line of arrowhead
|
||||
(send dc draw-spline
|
||||
(+ dx w)
|
||||
(+ dy line-pos)
|
||||
|
||||
(+ dx w (- head-width) (* head-width 1/5))
|
||||
(+ dy line-pos (+ (* head-height 4/16)))
|
||||
|
||||
(+ dx w (- head-width))
|
||||
(+ dy line-pos (+ (/ head-height 2))))
|
||||
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))
|
||||
w h (- h d) d)
|
||||
2 0)))))
|
||||
164
collects/redex/private/bitmap-test-util.ss
Normal file
164
collects/redex/private/bitmap-test-util.ss
Normal file
|
|
@ -0,0 +1,164 @@
|
|||
(module bitmap-test-util mzscheme
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "mrpict.ss" "texpict")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "class.ss")
|
||||
"../pict.ss"
|
||||
"../reduction-semantics.ss")
|
||||
|
||||
(provide test done)
|
||||
|
||||
(define-struct failed-test (panel))
|
||||
|
||||
(define tests 0)
|
||||
(define failed '())
|
||||
(define (done)
|
||||
(printf "~a tests" tests)
|
||||
(if (null? failed)
|
||||
(printf ", all passed\n")
|
||||
(printf ", ~a failed\n" (length failed))))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test-exp bitmap-filename)
|
||||
#`(test/proc
|
||||
#,(syntax-line stx)
|
||||
(λ () test-exp)
|
||||
bitmap-filename)]))
|
||||
|
||||
(define (test/proc line-number func raw-bitmap-filename)
|
||||
(set! tests (+ tests 1))
|
||||
(let* ([bitmap-filename (build-path "bmps" raw-bitmap-filename)]
|
||||
[old-bitmap (if (file-exists? bitmap-filename)
|
||||
(make-object bitmap% bitmap-filename)
|
||||
(let* ([bm (make-object bitmap% 100 20)]
|
||||
[bdc (make-object bitmap-dc% bm)])
|
||||
(send bdc clear)
|
||||
(send bdc draw-text "does not exist" 0 0)
|
||||
(send bdc set-bitmap #f)
|
||||
bm))]
|
||||
[pict (parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))])
|
||||
(func))]
|
||||
[new-bitmap (make-object bitmap%
|
||||
(inexact->exact (pict-width pict))
|
||||
(inexact->exact (pict-height pict)))]
|
||||
[bdc (make-object bitmap-dc% new-bitmap)])
|
||||
(send bdc clear)
|
||||
(draw-pict pict bdc 0 0)
|
||||
(send bdc set-bitmap #f)
|
||||
(let ([diff-bitmap (compute-diffs old-bitmap new-bitmap)])
|
||||
(when diff-bitmap
|
||||
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
|
||||
(set! failed (append failed (list (make-failed-test failed-panel)))))))))
|
||||
|
||||
(define (compute-diffs old-bitmap new-bitmap)
|
||||
(let* ([w (max (send old-bitmap get-width)
|
||||
(send new-bitmap get-width))]
|
||||
[h (max (send old-bitmap get-height)
|
||||
(send new-bitmap get-height))]
|
||||
[diff-bitmap (make-object bitmap% w h)]
|
||||
[new (make-object bitmap-dc% new-bitmap)]
|
||||
[old (make-object bitmap-dc% old-bitmap)]
|
||||
[diff (make-object bitmap-dc% diff-bitmap)]
|
||||
[new-c (make-object color%)]
|
||||
[old-c (make-object color%)]
|
||||
[any-different? #f])
|
||||
(let loop ([x 0])
|
||||
(unless (= x w)
|
||||
(let loop ([y 0])
|
||||
(unless (= y h)
|
||||
(cond
|
||||
[(and (<= x (send new-bitmap get-width))
|
||||
(<= y (send new-bitmap get-height))
|
||||
(<= x (send old-bitmap get-width))
|
||||
(<= y (send old-bitmap get-height)))
|
||||
(send new get-pixel x y new-c)
|
||||
(send old get-pixel x y old-c)
|
||||
(cond
|
||||
[(and (= (send new-c red) (send old-c red))
|
||||
(= (send new-c green) (send old-c green))
|
||||
(= (send new-c blue) (send old-c blue)))
|
||||
(send diff set-pixel x y new-c)]
|
||||
[else
|
||||
(set! any-different? #t)
|
||||
(send new-c set 255 0 0)
|
||||
(send diff set-pixel x y new-c)])]
|
||||
[else
|
||||
(set! any-different? #t)
|
||||
(send new-c set 255 0 0)
|
||||
(send diff set-pixel x y new-c)])
|
||||
(loop (+ y 1))))
|
||||
(loop (+ x 1))))
|
||||
(send diff set-bitmap #f)
|
||||
(send old set-bitmap #f)
|
||||
(send new set-bitmap #f)
|
||||
(and any-different? diff-bitmap)))
|
||||
|
||||
(define test-result-single-panel #f)
|
||||
(define (get-test-result-single-panel)
|
||||
(cond
|
||||
[test-result-single-panel
|
||||
test-result-single-panel]
|
||||
[else
|
||||
(let ()
|
||||
(define f (new frame% [label "bitmap-test.ss failures"]))
|
||||
(define lined (new vertical-panel% [parent f] [style '(border)]))
|
||||
(define sp (new panel:single% [parent lined]))
|
||||
(define current-index 0)
|
||||
(define hp (new horizontal-panel% [parent f]))
|
||||
(define prev
|
||||
(new button%
|
||||
[label "Prev"]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(set! current-index (modulo (- current-index 1) (length failed)))
|
||||
(update-gui))]))
|
||||
(define next (new button%
|
||||
[label "Next"]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(set! current-index (modulo (+ current-index 1) (length failed)))
|
||||
(update-gui))]))
|
||||
(define (update-gui)
|
||||
(send sp active-child (failed-test-panel (list-ref failed current-index))))
|
||||
(set! test-result-single-panel sp)
|
||||
(send f show #t)
|
||||
sp)]))
|
||||
|
||||
(define (make-failed-panel line-number filename old-bitmap new-bitmap diff-bitmap)
|
||||
(define f (new vertical-panel% [parent (get-test-result-single-panel)]))
|
||||
(define msg (new message% [label (format "line ~a" line-number)] [parent f]))
|
||||
(define hp (new horizontal-panel% [parent f]))
|
||||
(define vp1 (new vertical-panel% [parent hp]))
|
||||
(define vp2 (new vertical-panel% [parent hp]))
|
||||
(define chk (new check-box%
|
||||
[label "Show diff"]
|
||||
[parent f]
|
||||
[callback
|
||||
(λ (_1 _2)
|
||||
(cond
|
||||
[(send chk get-value)
|
||||
(send chk set-label "Hide diff")
|
||||
(send right-hand set-label diff-bitmap)]
|
||||
[else
|
||||
(send chk set-label "Show diff")
|
||||
(send right-hand set-label new-bitmap)]))]))
|
||||
(define btn (new button%
|
||||
[parent f]
|
||||
[label "Save"]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(send new-bitmap save-file filename 'png))]))
|
||||
(define left-label (new message% [parent vp1] [label "Old"]))
|
||||
(define left-hand (new message%
|
||||
[parent vp1]
|
||||
[label diff-bitmap]))
|
||||
(define right-label (new message% [parent vp2] [label "New"]))
|
||||
(define right-hand (new message%
|
||||
[parent vp2]
|
||||
[label diff-bitmap]))
|
||||
(send left-hand set-label old-bitmap)
|
||||
(send right-hand set-label new-bitmap)
|
||||
f))
|
||||
44
collects/redex/private/bitmap-test.ss
Normal file
44
collects/redex/private/bitmap-test.ss
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
(module bitmap-test mzscheme
|
||||
(require "bitmap-test-util.ss"
|
||||
"../pict.ss"
|
||||
"../reduction-semantics.ss")
|
||||
|
||||
;; tests:
|
||||
;; - language,
|
||||
;; - multi-line non-terminals, single-line non-terminals
|
||||
(define-language lang
|
||||
(e (e e)
|
||||
x
|
||||
(λ (x) e)
|
||||
number)
|
||||
(v number (λ (x) e))
|
||||
((x y) variable-not-otherwise-mentioned))
|
||||
(test (language->pict lang #f) "language.png")
|
||||
|
||||
(define-extended-language lang++ lang
|
||||
(e .... number (+ e e))
|
||||
(v .... number))
|
||||
|
||||
(test (language->pict lang++ #f) "extended-language.png")
|
||||
|
||||
(define red
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> ((λ (x) e) v) (S x v e))))
|
||||
|
||||
;; tests: reduction-relation
|
||||
(test (reduction-relation->pict red)
|
||||
"reduction-relation.png")
|
||||
|
||||
(test (reduction-relation->pict
|
||||
(extend-reduction-relation red lang (--> 1 2)))
|
||||
"extended-reduction-relation.png")
|
||||
|
||||
(define-multi-args-metafunction S lang
|
||||
[(x v e) e])
|
||||
|
||||
(test (metafunction->pict S)
|
||||
"metafunction.png")
|
||||
|
||||
(printf "bitmap-test.ss: ")
|
||||
(done))
|
||||
BIN
collects/redex/private/bmps/extended-language.png
Normal file
BIN
collects/redex/private/bmps/extended-language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.0 KiB |
BIN
collects/redex/private/bmps/extended-reduction-relation.png
Normal file
BIN
collects/redex/private/bmps/extended-reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 398 B |
BIN
collects/redex/private/bmps/language.png
Normal file
BIN
collects/redex/private/bmps/language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.7 KiB |
BIN
collects/redex/private/bmps/metafunction.png
Normal file
BIN
collects/redex/private/bmps/metafunction.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.1 KiB |
BIN
collects/redex/private/bmps/reduction-relation.png
Normal file
BIN
collects/redex/private/bmps/reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.7 KiB |
71
collects/redex/private/color-test.ss
Normal file
71
collects/redex/private/color-test.ss
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
#|
|
||||
|
||||
tests the color setting ability during a reduction sequence.
|
||||
|
||||
In one window, you expect to see a red and a blue snip. as you reduce you expect to see a spectrum from blue to red
|
||||
|
||||
In the other window, you expect to see the currently unreducted terms in green and all others white.
|
||||
|
||||
|#
|
||||
|
||||
(module color-test mzscheme
|
||||
(require "../reduction-semantics.ss"
|
||||
"../gui.ss"
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss"))
|
||||
|
||||
(reduction-steps-cutoff 1)
|
||||
|
||||
(let ()
|
||||
|
||||
(define (get-range term-node)
|
||||
(let loop ([node term-node])
|
||||
(let ([parents (term-node-parents node)])
|
||||
(cond
|
||||
[(null? parents) (list node)]
|
||||
[else (cons node (loop (car parents)))]))))
|
||||
|
||||
(define (color-range-pred sexp term-node)
|
||||
(let* ([parents (get-range term-node)]
|
||||
[max-val (car (term-node-expr (car parents)))])
|
||||
(for-each
|
||||
(λ (node)
|
||||
(let ([val (car (term-node-expr node))])
|
||||
(term-node-set-color! node
|
||||
(make-object color%
|
||||
(floor (- 255 (* val (/ 255 max-val))))
|
||||
0
|
||||
(floor (* val (/ 255 max-val)))))))
|
||||
parents)))
|
||||
|
||||
(define-language empty-language)
|
||||
|
||||
(traces/pred empty-language
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> (number_1 word)
|
||||
(,(+ (term number_1) 1) word)
|
||||
inc))
|
||||
(list '(1 word))
|
||||
color-range-pred))
|
||||
|
||||
(let ()
|
||||
(define-language empty-language)
|
||||
|
||||
(define (last-color-pred sexp term-node)
|
||||
(term-node-set-color! term-node
|
||||
(if (null? (term-node-children term-node))
|
||||
"green"
|
||||
"white")))
|
||||
|
||||
(traces/pred empty-language
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> (number_1 word)
|
||||
(,(+ (term number_1) 1) word)
|
||||
inc)
|
||||
(--> (number_1 word)
|
||||
(,(* (term number_1) 2) word)
|
||||
dup))
|
||||
(list '(1 word))
|
||||
last-color-pred)))
|
||||
55
collects/redex/private/core-layout-test.ss
Normal file
55
collects/redex/private/core-layout-test.ss
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
(module core-layout-test mzscheme
|
||||
(require "core-layout.ss"
|
||||
"loc-wrapper.ss"
|
||||
"lw-test-util.ss"
|
||||
"test-util.ss"
|
||||
(lib "struct.ss"))
|
||||
|
||||
(require (lib "mrpict.ss" "texpict")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss"))
|
||||
(dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1)))
|
||||
|
||||
(reset-count)
|
||||
|
||||
(let ([content
|
||||
(list (make-lw 'x 15 1 35 0 #f #f)
|
||||
(make-lw (list
|
||||
(make-lw "(" 15 0 35 1 #f #f)
|
||||
(make-lw 'a 15 0 36 1 #f #f)
|
||||
(make-lw 'b 16 0 36 1 #f #f)
|
||||
(make-lw ")" 16 0 37 1 #f #f))
|
||||
15 1 35 3 #f #f))])
|
||||
(test (find-enclosing-loc-wrapper content)
|
||||
(build-lw content
|
||||
15 1 35 3)))
|
||||
|
||||
(define (replace-pict-tokens x)
|
||||
(let loop ([x x])
|
||||
(cond
|
||||
[(pair? x) (cons (loop (car x))
|
||||
(loop (cdr x)))]
|
||||
[(pict-token? x)
|
||||
(copy-struct pict-token x [pict-token-pict 'pict])]
|
||||
[else x])))
|
||||
|
||||
(test (replace-pict-tokens
|
||||
(build-lines
|
||||
'()
|
||||
(normalize-lw
|
||||
(to-lw
|
||||
,(term
|
||||
(a b c))))))
|
||||
(list (list (make-spacer-token 0 2)
|
||||
(make-string-token 2 1 "(" 'roman)
|
||||
(make-string-token 3 1 "a" 'swiss)
|
||||
(make-string-token 4 1 " " 'roman)
|
||||
(make-string-token 5 1 "b" 'swiss)
|
||||
(make-string-token 6 1 " " 'roman)
|
||||
(make-string-token 7 1 "c" 'swiss)
|
||||
(make-string-token 8 1 ")" 'roman))
|
||||
(list (make-string-token 0 0 "" 'roman)
|
||||
(make-pict-token 0 1 'pict)
|
||||
(make-pict-token 1 0 'pict))))
|
||||
|
||||
(print-tests-passed "core-layout.ss"))
|
||||
739
collects/redex/private/core-layout.ss
Normal file
739
collects/redex/private/core-layout.ss
Normal file
|
|
@ -0,0 +1,739 @@
|
|||
|
||||
(module core-layout mzscheme
|
||||
(require "loc-wrapper.ss"
|
||||
"matcher.ss"
|
||||
"reduction-semantics.ss"
|
||||
(lib "list.ss")
|
||||
(lib "utils.ss" "texpict")
|
||||
(lib "mrpict.ss" "texpict")
|
||||
(lib "etc.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "struct.ss"))
|
||||
|
||||
(provide find-enclosing-loc-wrapper
|
||||
lw->pict
|
||||
basic-text
|
||||
metafunction-text
|
||||
default-style
|
||||
label-style
|
||||
non-terminal-style
|
||||
non-terminal-subscript-style
|
||||
label-font-size
|
||||
default-font-size
|
||||
metafunction-font-size
|
||||
non-terminal
|
||||
literal-style
|
||||
metafunction-style
|
||||
open-white-square-bracket
|
||||
close-white-square-bracket
|
||||
just-before
|
||||
just-after
|
||||
with-unquote-rewriter
|
||||
with-compound-rewriter
|
||||
with-atomic-rewriter
|
||||
STIX?
|
||||
|
||||
;; for test suite
|
||||
build-lines
|
||||
(struct token (column span))
|
||||
(struct string-token (string style))
|
||||
(struct pict-token (pict))
|
||||
(struct spacer-token ())
|
||||
|
||||
current-text)
|
||||
|
||||
|
||||
(define STIX? #f)
|
||||
|
||||
;; atomic-rewrite-table : (parameter (listof (list symbol (union string pict))))
|
||||
(define atomic-rewrite-table
|
||||
(make-parameter
|
||||
`((... ,(if STIX?
|
||||
(basic-text "\u22ef" (default-style))
|
||||
"..."))
|
||||
(hole "[]"))))
|
||||
|
||||
(define-syntax (with-atomic-rewriter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name transformer e)
|
||||
#'(parameterize ([atomic-rewrite-table
|
||||
(cons (list name transformer)
|
||||
(atomic-rewrite-table))])
|
||||
e)]))
|
||||
|
||||
;; compound-rewrite-table : (listof lw) -> (listof (union lw pict string))
|
||||
(define compound-rewrite-table
|
||||
(make-parameter
|
||||
`((in-hole ,(λ (args)
|
||||
(let ([context (list-ref args 2)]
|
||||
[thing-in-hole (list-ref args 3)])
|
||||
(if (and (lw? thing-in-hole)
|
||||
(equal? (lw-e thing-in-hole) 'hole))
|
||||
(list (blank) context (blank))
|
||||
(list (blank) context "" "[" thing-in-hole "]")))))
|
||||
(in-named-hole ,(λ (args)
|
||||
(let ([name (lw-e (list-ref args 2))]
|
||||
[context (list-ref args 3)]
|
||||
[thing-in-hole (list-ref args 4)])
|
||||
(if (and (lw? thing-in-hole)
|
||||
(equal? (lw-e thing-in-hole) 'hole))
|
||||
(list (blank) context "[]"
|
||||
(basic-text (format "~a" name) (non-terminal-subscript-style)))
|
||||
(list (blank) context "" "[" thing-in-hole "]"
|
||||
(basic-text (format "~a" name) (non-terminal-subscript-style)))))))
|
||||
(hide-hole ,(λ (args)
|
||||
(list (blank)
|
||||
(list-ref args 2)
|
||||
(blank))))
|
||||
(hole ,(λ (args)
|
||||
(let ([name (lw-e (list-ref args 2))])
|
||||
(list "[]"
|
||||
(basic-text (format "~a" name) (non-terminal-subscript-style))))))
|
||||
(name ,(λ (args)
|
||||
(let ([open-paren (list-ref args 0)]
|
||||
[the-name (list-ref args 2)]
|
||||
[close-paren (list-ref args 4)])
|
||||
(list (blank)
|
||||
the-name
|
||||
(blank))))))))
|
||||
|
||||
(define-syntax (with-compound-rewriter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name transformer e)
|
||||
#'(parameterize ([compound-rewrite-table
|
||||
(cons (list name transformer)
|
||||
(compound-rewrite-table))])
|
||||
e)]))
|
||||
|
||||
(define-syntax (with-unquote-rewriter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ transformer e)
|
||||
#'(parameterize ([current-unquote-rewriter transformer])
|
||||
e)]))
|
||||
(define current-unquote-rewriter (make-parameter values))
|
||||
|
||||
|
||||
|
||||
;; token = string-token | spacer-token | pict-token | align-token
|
||||
|
||||
(define-struct token (column span) (make-inspector))
|
||||
|
||||
;; string : string
|
||||
;; style : valid third argument to mrpict.ss's `text' function
|
||||
(define-struct (string-token token) (string style) (make-inspector))
|
||||
|
||||
;; width : number
|
||||
;; pict : pict
|
||||
(define-struct (pict-token token) (pict) (make-inspector))
|
||||
|
||||
;; spacer : number
|
||||
(define-struct (spacer-token token) () (make-inspector))
|
||||
|
||||
;; pict : pict
|
||||
;; this token always appears at the beginning of a line and its width
|
||||
;; is the x-coordinate of the pict inside itself (which must appear on
|
||||
;; an earlier line)
|
||||
(define-struct align-token (pict) (make-inspector))
|
||||
|
||||
(define (lw->pict nts lw)
|
||||
(lines->pict
|
||||
(setup-lines
|
||||
(build-lines
|
||||
(if (compiled-lang? nts)
|
||||
(language-nts nts)
|
||||
nts)
|
||||
(apply-rewrites lw)))))
|
||||
|
||||
(define (apply-rewrites orig-lw)
|
||||
(define (ar/lw an-lw)
|
||||
(cond
|
||||
[(eq? 'spring an-lw) an-lw]
|
||||
[(lw? an-lw)
|
||||
(let* ([w-out-term-let (remove-term-let an-lw)]
|
||||
[rewritten
|
||||
(if (lw-unq? w-out-term-let)
|
||||
((current-unquote-rewriter) w-out-term-let)
|
||||
w-out-term-let)])
|
||||
(if (equal? rewritten an-lw)
|
||||
(copy-struct lw
|
||||
an-lw
|
||||
[lw-e (ar/e (lw-e an-lw)
|
||||
(lw-line an-lw)
|
||||
(lw-line-span an-lw)
|
||||
(lw-column an-lw)
|
||||
(lw-column-span an-lw))])
|
||||
(ar/lw rewritten)))]))
|
||||
|
||||
(define (remove-term-let an-lw)
|
||||
(if (lw-unq? an-lw)
|
||||
(let ([content (lw-e an-lw)])
|
||||
(if (and (pair? content)
|
||||
(pair? (cdr content))
|
||||
(lw? (cadr content))
|
||||
(equal? 'term-let (lw-e (cadr content))))
|
||||
(copy-struct lw
|
||||
an-lw
|
||||
[lw-e (lw-e (second-to-last content))])
|
||||
an-lw))
|
||||
an-lw))
|
||||
|
||||
(define (ar/e e line line-span col col-span)
|
||||
(cond
|
||||
[(and (symbol? e) (assoc e (atomic-rewrite-table)))
|
||||
=>
|
||||
(λ (m)
|
||||
(when (eq? (cadr m) e)
|
||||
(error 'apply-rewrites "rewritten version of ~s is still ~s" e e))
|
||||
(let ([p (cadr m)])
|
||||
(if (procedure? p)
|
||||
(p)
|
||||
p)))]
|
||||
[(symbol? e) e]
|
||||
[(string? e) e]
|
||||
[(pict? e) e]
|
||||
[(and (pair? e)
|
||||
(lw? (car e))
|
||||
(member (lw-e (car e)) '("(" "[" "{")) ;; ensures we're really beginning a sequence
|
||||
;; only useful for typesetting grammars, due to
|
||||
;; the loc-wrappers that it synthesizes
|
||||
(pair? (cdr e))
|
||||
(lw? (cadr e))
|
||||
(assoc (lw-e (cadr e)) (compound-rewrite-table)))
|
||||
=>
|
||||
(λ (m)
|
||||
(let ([rewritten ((cadr m) e)])
|
||||
(when (and (pair? rewritten)
|
||||
(pair? (cdr rewritten))
|
||||
(eq? (cadr rewritten)
|
||||
(cadr e)))
|
||||
(error 'apply-rewrites "rewritten version still has symbol of the same name as original: ~s"
|
||||
(cadr rewritten)))
|
||||
(let ([adjusted
|
||||
(adjust-spacing rewritten
|
||||
line line-span col col-span
|
||||
(lw-e (cadr e)))])
|
||||
(map ar/lw adjusted))))]
|
||||
[(and (pair? e)
|
||||
(pair? (cdr e))
|
||||
(lw? (cadr e))
|
||||
(lw-metafunction-name (cadr e)))
|
||||
(map ar/lw (adjust-spacing (rewrite-metafunction-app (lw-metafunction-name (cadr e)) e)
|
||||
line line-span col col-span
|
||||
(lw-e (cadr e))))]
|
||||
[else
|
||||
(map ar/lw e)]))
|
||||
(ar/lw orig-lw))
|
||||
|
||||
(define (second-to-last l)
|
||||
(cond
|
||||
[(null? l) (error 'second-to-last "empty list")]
|
||||
[(null? (cdr l)) (error 'second-to-last "one element list")]
|
||||
[else (let loop ([l (cddr l)]
|
||||
[fst (car l)]
|
||||
[snd (cadr l)])
|
||||
(cond
|
||||
[(null? l) fst]
|
||||
[else (loop (cdr l)
|
||||
snd
|
||||
(car l))]))]))
|
||||
|
||||
(define (rewrite-metafunction-app kind lst)
|
||||
(case kind
|
||||
[(single)
|
||||
(list* (hbl-append
|
||||
(metafunction-text (symbol->string (lw-e (cadr lst))))
|
||||
(open-white-square-bracket))
|
||||
(let loop ([lst (cddr lst)])
|
||||
(cond
|
||||
[(null? lst) null]
|
||||
[(null? (cdr lst))
|
||||
(let ([last (car lst)])
|
||||
(list (just-before (close-white-square-bracket) last)))]
|
||||
[else (cons (car lst) (loop (cdr lst)))])))]
|
||||
[(multi)
|
||||
(cons (hbl-append
|
||||
(metafunction-text (symbol->string (lw-e (cadr lst))))
|
||||
(open-white-square-bracket))
|
||||
(let loop ([lst (cddr lst)])
|
||||
(cond
|
||||
[(null? lst) null]
|
||||
[(null? (cdr lst))
|
||||
(let ([last (car lst)])
|
||||
(list (just-before (close-white-square-bracket) last)))]
|
||||
[(null? (cddr lst))
|
||||
(cons (car lst) (loop (cdr lst)))]
|
||||
[else (list* (car lst)
|
||||
(basic-text ", " (default-style))
|
||||
(loop (cdr lst)))])))]))
|
||||
|
||||
(define (just-before what lw)
|
||||
(build-lw (if (symbol? what)
|
||||
(symbol->string what)
|
||||
what)
|
||||
(lw-line lw)
|
||||
0
|
||||
(lw-column lw)
|
||||
0))
|
||||
|
||||
(define (just-after what lw)
|
||||
(build-lw (if (symbol? what)
|
||||
(symbol->string what)
|
||||
what)
|
||||
(+ (lw-line lw) (lw-line-span lw))
|
||||
0
|
||||
(+ (lw-column lw) (lw-column-span lw))
|
||||
0))
|
||||
|
||||
;; adjust-spacing : (listof (union string pict loc-wrapper))
|
||||
;; number
|
||||
;; number
|
||||
;; symbol
|
||||
;; -> (listof loc-wrapper)
|
||||
;; builds loc-wrappers out of the strings in the rewrittens,
|
||||
;; using the originals around the string in order to find column numbers for the strings
|
||||
;; NB: there is still an issue with this code -- if the rewrite drops stuff that
|
||||
;; appears at the end of the sequence, blank space will still appear in the final output ...
|
||||
;; When this is fixed, remove the workaround for the `in-hole' rewriter.
|
||||
(define (adjust-spacing in-rewrittens init-line init-line-span init-column init-column-span who)
|
||||
(let loop ([rewrittens in-rewrittens]
|
||||
[line init-line]
|
||||
[column init-column])
|
||||
(let* ([to-wrap (collect-non-lws rewrittens)]
|
||||
[next-lw (first-lws rewrittens)]
|
||||
[after-next-lw (drop-to-lw-and1 rewrittens)]
|
||||
[next-lw-line (if next-lw
|
||||
(lw-line next-lw)
|
||||
(+ init-line init-line-span))]
|
||||
[next-lw-column (if next-lw
|
||||
(lw-column next-lw)
|
||||
(+ init-column init-column-span))])
|
||||
;; error checking
|
||||
(cond
|
||||
[(= line next-lw-line)
|
||||
(when (next-lw-column . < . column)
|
||||
(error 'adjust-spacing "for ~a; loc-wrapper takes up too many columns. Expected it to not pass ~a, but it went to ~a"
|
||||
who
|
||||
next-lw-column
|
||||
column))]
|
||||
[(next-lw-line . < . line)
|
||||
(error 'adjust-spacing "for ~a; last loc-wrapper takes up too many lines. Expected it to not pass line ~a, but it went to ~a"
|
||||
who
|
||||
next-lw-line
|
||||
line)])
|
||||
(let* ([next-line (+ next-lw-line
|
||||
(if next-lw
|
||||
(lw-line-span next-lw)
|
||||
0))]
|
||||
[next-column (+ next-lw-column
|
||||
(if next-lw
|
||||
(lw-column-span next-lw)
|
||||
0))])
|
||||
(cond
|
||||
[(and after-next-lw (null? to-wrap))
|
||||
(cons next-lw (loop after-next-lw next-line next-column))]
|
||||
[(and (not after-next-lw) (null? to-wrap))
|
||||
'()]
|
||||
[else
|
||||
(let-values ([(to-wrap1 to-wrap2) (extract-pieces-to-wrap who to-wrap)])
|
||||
(let ([new-lw-col
|
||||
(if (= line next-lw-line)
|
||||
column
|
||||
init-column)]
|
||||
[new-lw-col-span
|
||||
(if (= line next-lw-line)
|
||||
(- next-lw-column column)
|
||||
(- next-lw-column init-column))])
|
||||
(list* (build-lw to-wrap1 line 0 new-lw-col 0)
|
||||
(build-lw (blank)
|
||||
line
|
||||
(- next-lw-line line)
|
||||
new-lw-col
|
||||
new-lw-col-span)
|
||||
(build-lw to-wrap2 next-lw-line 0 (+ new-lw-col new-lw-col-span) 0)
|
||||
(if after-next-lw
|
||||
(cons next-lw (loop after-next-lw next-line next-column))
|
||||
'()))))])))))
|
||||
|
||||
(define (extract-pieces-to-wrap who lst)
|
||||
(let ([fst (car lst)])
|
||||
(if (pair? (cdr lst))
|
||||
(let ([snd (cadr lst)])
|
||||
(when (pair? (cddr lst))
|
||||
(error 'adjust-spacing
|
||||
"for ~a; found ~a consecutive loc-wrappers, expected at most 2: ~a"
|
||||
who
|
||||
(length lst)
|
||||
(apply string-append
|
||||
(format "~s" (car lst))
|
||||
(map (λ (x) (format " ~s" x)) (cdr lst)))))
|
||||
(values fst snd))
|
||||
(values fst (blank)))))
|
||||
|
||||
(define (combine-into-loc-wrapper to-wrap)
|
||||
(cond
|
||||
[(null? to-wrap) (blank)]
|
||||
[(null? (cdr to-wrap)) (car to-wrap)]
|
||||
[else
|
||||
(apply hbl-append (map make-single-pict to-wrap))]))
|
||||
|
||||
(define (make-single-pict x)
|
||||
(cond
|
||||
[(pict? x) x]
|
||||
[(string? x) (basic-text x (default-style))]))
|
||||
|
||||
(define (drop-to-lw-and1 lst)
|
||||
(let loop ([lst lst])
|
||||
(cond
|
||||
[(null? lst) #f]
|
||||
[else
|
||||
(let ([ele (car lst)])
|
||||
(if (lw? ele)
|
||||
(cdr lst)
|
||||
(loop (cdr lst))))])))
|
||||
|
||||
(define (collect-non-lws lst)
|
||||
(let loop ([lst lst])
|
||||
(cond
|
||||
[(null? lst) null]
|
||||
[else
|
||||
(let ([ele (car lst)])
|
||||
(if (lw? ele)
|
||||
null
|
||||
(cons ele (loop (cdr lst)))))])))
|
||||
|
||||
(define (first-lws lst)
|
||||
(let loop ([lst lst])
|
||||
(cond
|
||||
[(null? lst) #f]
|
||||
[else
|
||||
(let ([ele (car lst)])
|
||||
(if (lw? ele)
|
||||
ele
|
||||
(loop (cdr lst))))])))
|
||||
|
||||
(define (build-lines all-nts lw)
|
||||
(define initial-column (lw-column lw))
|
||||
(define initial-line (lw-line lw))
|
||||
(define current-line (lw-line lw))
|
||||
(define current-column (lw-column lw))
|
||||
(define last-token-spring? #f)
|
||||
(define tokens '())
|
||||
(define lines '())
|
||||
(define (eject line col span atom unquoted?)
|
||||
(unless (= current-line line)
|
||||
;; make new lines
|
||||
(for-each
|
||||
(λ (x)
|
||||
(set! lines (cons (reverse tokens) lines))
|
||||
(set! tokens '()))
|
||||
(build-list (max 0 (- line current-line)) (λ (x) 'whatever)))
|
||||
|
||||
(set! tokens (cons (make-spacer-token 0 (- col initial-column))
|
||||
tokens))
|
||||
|
||||
(set! current-line line)
|
||||
(set! current-column col))
|
||||
(when (< current-column col)
|
||||
(let ([space-span (- col current-column)])
|
||||
(set! tokens (cons (make-blank-space-token unquoted?
|
||||
(- current-column initial-column)
|
||||
space-span)
|
||||
tokens))))
|
||||
(set! last-token-spring? #f)
|
||||
(set! tokens (append
|
||||
(reverse
|
||||
(atom->tokens (- col initial-column) span atom all-nts unquoted?))
|
||||
tokens))
|
||||
(set! current-column (+ col span)))
|
||||
|
||||
(define (make-blank-space-token unquoted? col span)
|
||||
(if last-token-spring?
|
||||
(make-pict-token col span (blank))
|
||||
(let ([str (apply string (build-list span (λ (x) #\space)))])
|
||||
(if unquoted?
|
||||
(make-pict-token col span (pink-background ((current-text) str 'modern (default-font-size))))
|
||||
(make-string-token col span str (default-style))))))
|
||||
|
||||
(define (handle-loc-wrapped lw last-line last-column last-span)
|
||||
(cond
|
||||
[(eq? lw 'spring)
|
||||
(set! last-token-spring? #t)]
|
||||
[else
|
||||
(handle-object (lw-e lw)
|
||||
(lw-line lw)
|
||||
(lw-column lw)
|
||||
(lw-column-span lw)
|
||||
(lw-unq? lw))]))
|
||||
|
||||
(define (handle-object obj line col span unquoted?)
|
||||
(cond
|
||||
[(symbol? obj) (eject line col span obj unquoted?)]
|
||||
[(string? obj) (eject line col span obj unquoted?)]
|
||||
[(pict? obj) (eject line col span obj unquoted?)]
|
||||
[(not obj) (eject line col span (blank) unquoted?)]
|
||||
[else
|
||||
(for-each (λ (x) (handle-loc-wrapped x line col span))
|
||||
obj)]))
|
||||
|
||||
(handle-loc-wrapped lw 0 0 0)
|
||||
(set! lines (cons (reverse tokens) lines)) ;; handle last line ejection
|
||||
lines)
|
||||
|
||||
;; setup-lines : (listof (listof token)) -> (listof (listof token))
|
||||
;; removes the spacer tokens from the beginning of lines, replacing them with align tokens
|
||||
;; expects the lines to be in reverse order
|
||||
(define (setup-lines lines)
|
||||
(let loop ([lines lines])
|
||||
(cond
|
||||
[(null? lines) null]
|
||||
[else
|
||||
(let ([line (car lines)]
|
||||
[rst (cdr lines)])
|
||||
(if (null? line)
|
||||
(cons line (loop (cdr lines)))
|
||||
(if (spacer-token? (car line))
|
||||
(let ([pict (blank)])
|
||||
(if (andmap null? rst)
|
||||
(cons (cdr line) (loop rst))
|
||||
(let ([rst (split-out (token-span (car line))
|
||||
pict
|
||||
rst)])
|
||||
(cons (cons (make-align-token pict) (cdr line))
|
||||
(loop rst)))))
|
||||
(cons line (loop (cdr lines))))))])))
|
||||
|
||||
(define (split-out col pict lines)
|
||||
(let ([new-token (make-pict-token col 0 pict)])
|
||||
(let loop ([lines lines])
|
||||
(cond
|
||||
[(null? lines)
|
||||
;; this case can happen when the line in question is to the left of all other lines
|
||||
(error 'exchange-spacer "could not find matching line")]
|
||||
[else (let ([line (car lines)])
|
||||
(if (null? line)
|
||||
(cons line (loop (cdr lines)))
|
||||
(let ([spacer (car line)])
|
||||
(cond
|
||||
[(not (spacer-token? spacer))
|
||||
(cons (insert-new-token col new-token (token-column spacer) (car lines))
|
||||
(cdr lines))]
|
||||
[(= (token-span spacer)
|
||||
col)
|
||||
(cons (list* spacer new-token (cdr line))
|
||||
(cdr lines))]
|
||||
[(> (token-span spacer)
|
||||
col)
|
||||
(cons line (loop (cdr lines)))]
|
||||
[(< (token-span spacer)
|
||||
col)
|
||||
(cons (insert-new-token col new-token (token-column spacer) (car lines))
|
||||
(cdr lines))]))))]))))
|
||||
|
||||
(define (insert-new-token column-to-insert new-token init-width line)
|
||||
(let loop ([line line]
|
||||
[column 0])
|
||||
(cond
|
||||
[(null? line)
|
||||
(list new-token)]
|
||||
[else
|
||||
(let ([tok (car line)])
|
||||
(unless (token? tok)
|
||||
(error 'insert-new-token "ack ~s" tok))
|
||||
(cond
|
||||
[(<= column-to-insert (token-column tok))
|
||||
(cons new-token line)]
|
||||
[(< (token-column tok)
|
||||
column-to-insert
|
||||
(+ (token-column tok) (token-span tok)))
|
||||
(append (split-token (- column-to-insert (token-column tok)) tok new-token)
|
||||
(cdr line))]
|
||||
[(= column-to-insert (+ (token-column tok) (token-span tok)))
|
||||
(list* (car line) new-token (cdr line))]
|
||||
[else
|
||||
(cons (car line)
|
||||
(loop (cdr line)
|
||||
(+ (token-column tok) (token-span tok))))]))])))
|
||||
|
||||
(define (split-token offset tok new-token)
|
||||
(cond
|
||||
[(string-token? tok)
|
||||
(list (make-string-token (token-column tok)
|
||||
offset
|
||||
(substring (string-token-string tok)
|
||||
0 offset)
|
||||
(string-token-style tok))
|
||||
new-token
|
||||
(make-string-token (+ (token-column tok) offset)
|
||||
(- (token-span tok) offset)
|
||||
(substring (string-token-string tok)
|
||||
offset
|
||||
(string-length (string-token-string tok)))
|
||||
(string-token-style tok)))]
|
||||
[(pict-token? tok)
|
||||
(list new-token)]))
|
||||
|
||||
;; lines->pict : (listof (listof token)) -> pict
|
||||
;; expects the lines to be in order from bottom to top
|
||||
(define (lines->pict lines)
|
||||
(let loop ([lines lines])
|
||||
(cond
|
||||
[(null? lines) (blank)]
|
||||
[(null? (cdr lines))
|
||||
(handle-single-line (car lines) (blank))]
|
||||
[else
|
||||
(let ([rst (loop (cdr lines))])
|
||||
(vl-append rst (handle-single-line (car lines) rst)))])))
|
||||
|
||||
(define (handle-single-line line rst)
|
||||
(cond
|
||||
[(null? line)
|
||||
(let ([h (pict-height (token->pict (make-string-token 0 0 "x" (default-style))))])
|
||||
(blank 0 h))]
|
||||
[else
|
||||
(if (align-token? (car line))
|
||||
(let-values ([(x y) (lt-find rst (align-token-pict (car line)))])
|
||||
(apply htl-append
|
||||
(blank x 0)
|
||||
(map token->pict (cdr line))))
|
||||
(apply htl-append (map token->pict line)))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; font specs
|
||||
;;
|
||||
|
||||
|
||||
(define (token->pict tok)
|
||||
(cond
|
||||
[(string-token? tok)
|
||||
(basic-text (string-token-string tok) (string-token-style tok))]
|
||||
[(pict-token? tok) (pict-token-pict tok)]
|
||||
[else (error 'token->pict "~s" tok)]))
|
||||
|
||||
|
||||
(define (atom->tokens col span atom all-nts unquoted?)
|
||||
(cond
|
||||
[(pict? atom)
|
||||
(list (make-pict-token col span atom))]
|
||||
[unquoted?
|
||||
(list (make-pict-token col span
|
||||
(pink-background
|
||||
((current-text) (if (string? atom) atom (format "~a" atom))
|
||||
'modern
|
||||
(default-font-size)))))]
|
||||
[(and (symbol? atom)
|
||||
(regexp-match #rx"^([^_]*)_(.*)$" (symbol->string atom)))
|
||||
=>
|
||||
(λ (m)
|
||||
(let* ([first-part (cadr m)]
|
||||
[second-part (caddr m)]
|
||||
[first-span (- span (string-length first-part))])
|
||||
(list
|
||||
(make-string-token col
|
||||
first-span
|
||||
first-part
|
||||
(non-terminal-style))
|
||||
(make-string-token (+ col first-span)
|
||||
(- span first-span)
|
||||
second-part
|
||||
(non-terminal-subscript-style)))))]
|
||||
[(or (memq atom all-nts)
|
||||
(memq atom '(number variable variable-except variable-not-otherwise-mentioned)))
|
||||
(list (make-string-token col span (format "~s" atom) (non-terminal-style)))]
|
||||
[(symbol? atom)
|
||||
(list (make-string-token col span (symbol->string atom) (literal-style)))]
|
||||
[(string? atom)
|
||||
(list (make-string-token col span atom (default-style)))]
|
||||
[else (error 'atom->tokens "unk ~s" atom)]))
|
||||
|
||||
(define (pick-font lst fallback)
|
||||
(let ([fl (get-face-list 'all)])
|
||||
(let loop ([lst lst])
|
||||
(cond
|
||||
[(null? lst) fallback]
|
||||
[else (if (member (car lst) fl)
|
||||
(car lst)
|
||||
(loop (cdr lst)))]))))
|
||||
|
||||
(define current-text (make-parameter text))
|
||||
|
||||
(define (basic-text str style) ((current-text) str style (default-font-size)))
|
||||
(define (non-terminal str) ((current-text) str (non-terminal-style) (default-font-size)))
|
||||
(define (unksc str) (pink-background ((current-text) str 'modern (default-font-size))))
|
||||
(define non-terminal-style (make-parameter '(italic . roman)))
|
||||
(define non-terminal-subscript-style (make-parameter `(subscript . ,(non-terminal-style))))
|
||||
(define default-style (make-parameter 'roman))
|
||||
(define metafunction-style (make-parameter 'swiss))
|
||||
(define (metafunction-text str) ((current-text) str (metafunction-style) (metafunction-font-size)))
|
||||
(define literal-style (make-parameter 'swiss))
|
||||
(define label-style (make-parameter 'swiss))
|
||||
(define default-font-size (make-parameter 14))
|
||||
(define metafunction-font-size (make-parameter (default-font-size)))
|
||||
(define label-font-size (make-parameter 14))
|
||||
|
||||
(define (open-white-square-bracket) (white-bracket "["))
|
||||
(define (close-white-square-bracket) (white-bracket "]"))
|
||||
|
||||
(define (white-bracket str)
|
||||
(let ([inset-amt
|
||||
(case (default-font-size)
|
||||
[(9 10 11 12) -2]
|
||||
[else
|
||||
(- (floor (max 2 (* 2 (/ (default-font-size) 10)))))])])
|
||||
(hbl-append (basic-text str (default-style))
|
||||
(inset (basic-text str (default-style)) inset-amt 0 0 0))))
|
||||
|
||||
(define (pink-background p)
|
||||
(refocus
|
||||
(cc-superimpose
|
||||
(colorize (filled-rectangle (pict-width p)
|
||||
(pict-height p))
|
||||
"pink")
|
||||
p)
|
||||
p))
|
||||
|
||||
(define (add-between i l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[else
|
||||
(cons (car l)
|
||||
(apply append
|
||||
(map (λ (x) (list i x)) (cdr l))))]))
|
||||
|
||||
|
||||
;; for use
|
||||
(define (find-enclosing-loc-wrapper lws)
|
||||
(let* ([first-line (apply min (map lw-line lws))]
|
||||
[last-line (apply min (map (λ (x) (+ (lw-line x) (lw-line-span x))) lws))]
|
||||
[last-line-lws (find-lws-with-matching-last-line lws last-line)]
|
||||
[last-column (apply max (map (λ (x) (+ (lw-column x) (lw-column-span x))) last-line-lws))]
|
||||
[first-column (apply min (map lw-column last-line-lws))])
|
||||
(build-lw
|
||||
lws
|
||||
first-line
|
||||
(- last-line first-line)
|
||||
first-column
|
||||
(- last-column first-column))))
|
||||
|
||||
(define (find-lws-with-matching-last-line in-lws line)
|
||||
(define lws '())
|
||||
|
||||
(define (find/lw lw)
|
||||
(cond
|
||||
[(eq? lw 'spring) (void)]
|
||||
[(lw? lw)
|
||||
(when (= line (+ (lw-line lw) (lw-line-span lw)))
|
||||
(set! lws (cons lw lws))
|
||||
(find/e (lw-e lw)))]))
|
||||
|
||||
(define (find/e e)
|
||||
(cond
|
||||
[(symbol? e) (void)]
|
||||
[(string? e) (void)]
|
||||
[(pict? e) (void)]
|
||||
[else (for-each find/lw e)]))
|
||||
|
||||
(find/e in-lws)
|
||||
lws)
|
||||
|
||||
)
|
||||
300
collects/redex/private/dot.ss
Normal file
300
collects/redex/private/dot.ss
Normal file
|
|
@ -0,0 +1,300 @@
|
|||
#lang scheme/gui
|
||||
|
||||
(provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)]
|
||||
[find-dot (-> (or/c string? false/c))])
|
||||
|
||||
(require scheme/system)
|
||||
|
||||
(provide dot-label neato-label neato-hier-label neato-ipsep-label)
|
||||
(define dot-label "dot")
|
||||
(define neato-label "neato")
|
||||
(define neato-hier-label "neato – hier")
|
||||
(define neato-ipsep-label "neato – ipsep")
|
||||
|
||||
(define dot-paths
|
||||
'("/usr/bin"
|
||||
"/bin"
|
||||
"/usr/local/bin"
|
||||
"/opt/local/bin/"))
|
||||
|
||||
(define (find-dot [neato? #f])
|
||||
(ormap (λ (x) (and (file-exists? (build-path x "dot"))
|
||||
(file-exists? (build-path x "neato"))
|
||||
(path->string (build-path x (if neato? "neato" "dot")))))
|
||||
dot-paths))
|
||||
|
||||
(define (dot-positioning pb option overlap?)
|
||||
(let ([info (snip-info pb)])
|
||||
(let-values ([(cb positions max-y) (run-dot info option overlap?)])
|
||||
(send pb begin-edit-sequence)
|
||||
(send pb set-dot-callback
|
||||
(λ (pb dc left top right bottom dx dy)
|
||||
(let ([sm (send dc get-smoothing)]
|
||||
[pen (send dc get-pen)]
|
||||
[brush (send dc get-brush)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(cb dc left top right bottom dx dy)
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)
|
||||
(send dc set-smoothing sm))))
|
||||
(for-each
|
||||
(λ (position-line)
|
||||
(let* ([id (list-ref position-line 0)]
|
||||
[x (list-ref position-line 1)]
|
||||
[y (list-ref position-line 2)]
|
||||
[snip (car (hash-ref info id))])
|
||||
(send pb move-to snip x (- max-y y))))
|
||||
positions)
|
||||
(send pb invalidate-bitmap-cache)
|
||||
(send pb end-edit-sequence))))
|
||||
|
||||
;; with-snips : pasteboard% -> hash-table[snip -> (list i number[width] number[height] (listof number))]
|
||||
(define (snip-info pb)
|
||||
(let ([num-ht (make-hasheq)]
|
||||
[children-ht (make-hasheq)])
|
||||
(let loop ([snip (send pb find-first-snip)]
|
||||
[i 0])
|
||||
(when snip
|
||||
(hash-set! num-ht snip i)
|
||||
(loop (send snip next) (+ i 1))))
|
||||
(let ([lb (box 0)]
|
||||
[tb (box 0)]
|
||||
[rb (box 0)]
|
||||
[bb (box 0)])
|
||||
(hash-for-each
|
||||
num-ht
|
||||
(λ (snip num)
|
||||
(send pb get-snip-location snip lb tb #f)
|
||||
(send pb get-snip-location snip rb bb #t)
|
||||
(hash-set! children-ht
|
||||
(hash-ref num-ht snip)
|
||||
(list
|
||||
snip
|
||||
(- (unbox rb) (unbox lb))
|
||||
(- (unbox bb) (unbox tb))
|
||||
(map (λ (c) (hash-ref num-ht c))
|
||||
(send snip get-children))))))
|
||||
children-ht)))
|
||||
|
||||
;; run-dot : hash-table[snip -> (list i (listof number))] string -> void
|
||||
(define (run-dot ht option overlap?)
|
||||
(define info (sort (hash-map ht (λ (k v) (cons k v)))
|
||||
(λ (x y) (< (car x) (car y)))))
|
||||
(let-values ([(in1 out1) (make-pipe)]
|
||||
[(in2 out2) (make-pipe)])
|
||||
;;(graph->dot info option overlap?)
|
||||
(thread
|
||||
(λ ()
|
||||
(parameterize ([current-output-port out1])
|
||||
(graph->dot info option overlap?))
|
||||
(close-output-port out1)))
|
||||
(thread
|
||||
(λ ()
|
||||
(parameterize ([current-input-port in1]
|
||||
[current-output-port out2])
|
||||
(system (format "~a -Tplain" (find-dot (regexp-match #rx"neato" option)))))
|
||||
(close-output-port out2)
|
||||
(close-input-port in1)))
|
||||
(parse-plain in2)))
|
||||
|
||||
|
||||
;; graph->dot (listof (list snip number (listof number)) -> void
|
||||
;; prints out the dot input file based on `g'
|
||||
(define (graph->dot g option overlap?)
|
||||
(printf "digraph {\n")
|
||||
(cond
|
||||
[(equal? option dot-label)
|
||||
(printf " rankdir=\"~a\"\n" (if overlap? "LR" "TB"))]
|
||||
[(equal? option neato-label)
|
||||
(printf " overlap=\"~a\"\n" (if overlap? "true" "false"))
|
||||
(printf " splines=\"true\"\n")]
|
||||
[(equal? option neato-hier-label)
|
||||
(printf " overlap=\"~a\"\n" (if overlap? "true" "false"))
|
||||
(printf " mode=\"hier\"\n")
|
||||
(printf " splines=\"true\"\n")]
|
||||
[(equal? option neato-ipsep-label)
|
||||
(printf " mode=\"ipsep\"\n")
|
||||
(printf " splines=\"true\"\n")
|
||||
(printf " overlap=\"~a\"\n" (if overlap? "true" "ipsep"))])
|
||||
(for-each
|
||||
(λ (line)
|
||||
(let* ([snip (list-ref line 1)]
|
||||
[id (list-ref line 0)]
|
||||
[w (list-ref line 2)]
|
||||
[h (list-ref line 3)]
|
||||
[children (list-ref line 4)])
|
||||
(printf " ~a [width=~a height=~a shape=box label=\"\"]\n"
|
||||
(num->id id)
|
||||
(format-number (pixels->inches w))
|
||||
(format-number (pixels->inches h)))
|
||||
(for-each
|
||||
(λ (child)
|
||||
(printf " ~a -> ~a\n" (num->id id) (num->id child)))
|
||||
children)))
|
||||
g)
|
||||
(printf "}\n"))
|
||||
|
||||
(define (num->id n) (format "s~a" n))
|
||||
(define (id->num s) (string->number (substring s 1 (string-length s))))
|
||||
|
||||
(define (format-number n)
|
||||
(let ([candidate (number->string (exact->inexact n))])
|
||||
(cond
|
||||
[(regexp-match #rx"^([0-9]*)\\.([0-9]*)$" candidate)
|
||||
=>
|
||||
(λ (m)
|
||||
(let ([prefix (list-ref m 1)]
|
||||
[suffix (list-ref m 2)])
|
||||
(if (< (string-length suffix) 5)
|
||||
candidate
|
||||
(string-append prefix "." (substring suffix 0 4)))))]
|
||||
[else
|
||||
candidate])))
|
||||
|
||||
(define (parse-plain port)
|
||||
|
||||
(define max-y 0)
|
||||
|
||||
(define positions '())
|
||||
|
||||
(define (main)
|
||||
(let ([graph-line (read-line port)])
|
||||
(let loop ()
|
||||
(let ([line (read-line port)])
|
||||
(cond
|
||||
[(regexp-match #rx"^node" line)
|
||||
(join (parse-node line)
|
||||
(loop))]
|
||||
[(regexp-match #rx"^edge" line)
|
||||
(join (parse-edge line)
|
||||
(loop))]
|
||||
[(regexp-match #rx"stop" line)
|
||||
void]
|
||||
[else
|
||||
(error 'parse-file "didn't recognize line:\n ~s" line)])))))
|
||||
|
||||
(define (join p1 p2)
|
||||
(cond
|
||||
[(eq? p1 void) p2]
|
||||
[(eq? p2 void) p1]
|
||||
[else
|
||||
(λ (dc left top right bottom dx dy)
|
||||
(p1 dc left top right bottom dx dy)
|
||||
(p2 dc left top right bottom dx dy))]))
|
||||
|
||||
(define (parse-node line)
|
||||
(let*-values ([(node line) (chomp line)]
|
||||
[(id line) (chomp line)]
|
||||
[(raw-x line) (chomp line)]
|
||||
[(raw-y line) (chomp line)]
|
||||
[(raw-w line) (chomp line)]
|
||||
[(raw-h line) (chomp line)]
|
||||
[(label line) (chomp line)]
|
||||
[(style line) (chomp line)]
|
||||
[(raw-shape line) (chomp line)]
|
||||
[(color line) (chomp line)]
|
||||
[(fillcolor line) (chomp line)])
|
||||
|
||||
(define x (inches->pixels (string->number raw-x)))
|
||||
(define y (inches->pixels (string->number raw-y)))
|
||||
(define w (inches->pixels (string->number raw-w)))
|
||||
(define h (inches->pixels (string->number raw-h)))
|
||||
(define shape (string->symbol raw-shape))
|
||||
|
||||
(set! positions (cons (list (id->num id)
|
||||
(- x (/ w 2))
|
||||
(+ y (/ h 2)))
|
||||
positions))
|
||||
|
||||
(set! max-y (max (+ y h) max-y))
|
||||
void))
|
||||
|
||||
(define (parse-edge line)
|
||||
(let* ([m (regexp-match #rx"edge ([^ ]+) ([^ ]+) ([0-9]+) (.*)$" line)]
|
||||
[from (list-ref m 1)]
|
||||
[to (list-ref m 2)]
|
||||
[point-count (string->number (list-ref m 3))]
|
||||
[rest (list-ref m 4)]
|
||||
[points
|
||||
(let loop ([pts point-count]
|
||||
[rest rest])
|
||||
(if (zero? pts)
|
||||
'()
|
||||
(let* ([m (regexp-match #rx"^([0-9.]+) ([0-9.]+) (.*)$" rest)]
|
||||
[x (string->number (list-ref m 1))]
|
||||
[y (string->number (list-ref m 2))])
|
||||
(set! max-y (max y max-y))
|
||||
(cons (list x y)
|
||||
(loop (- pts 1)
|
||||
(list-ref m 3))))))])
|
||||
(λ (dc left top right bottom dx dy)
|
||||
(draw-edges dc dx dy points))))
|
||||
|
||||
;; chomp : string -> (values string (union #f string))
|
||||
;; returns the first word at the beginning of the string and the remainder of the string (or #f is there is no more)
|
||||
(define (chomp s)
|
||||
(let ([s (regexp-replace #rx"^ *" s "")])
|
||||
(cond
|
||||
[(equal? s "")
|
||||
(values "" #f)]
|
||||
[else
|
||||
(case (string-ref s 0)
|
||||
[(#\") (let ([m (regexp-match #rx"^\"([^\"]*)\"(.*)$" s)])
|
||||
(values (list-ref m 1)
|
||||
(list-ref m 2)))]
|
||||
[else
|
||||
(cond
|
||||
[(regexp-match #rx"^([^ ]*) (.*)$" s)
|
||||
=>
|
||||
(λ (m)
|
||||
(values (list-ref m 1)
|
||||
(list-ref m 2)))]
|
||||
[(regexp-match #rx"^([^ ]*)$" s)
|
||||
=>
|
||||
(λ (m)
|
||||
(values (list-ref m 1)
|
||||
#f))]
|
||||
[else
|
||||
(error 'chomp "~s" s)])])])))
|
||||
|
||||
(define (draw-edges dc dx dy raw-points)
|
||||
(let ([points (map (λ (x) (list (inches->pixels (car x))
|
||||
(inches->pixels (list-ref x 1))))
|
||||
raw-points)])
|
||||
(send dc set-pen "blue" 1 'solid)
|
||||
(send dc set-brush "black" 'transparent)
|
||||
(let ([path (new dc-path%)])
|
||||
(send path move-to
|
||||
(car (car points))
|
||||
(- max-y (cadr (car points))))
|
||||
(let loop ([points (cdr points)])
|
||||
(cond
|
||||
[(null? points) (void)]
|
||||
[else (let ([p1 (list-ref points 0)]
|
||||
[p2 (list-ref points 1)]
|
||||
[p3 (list-ref points 2)])
|
||||
(send path curve-to
|
||||
(list-ref p1 0) (- max-y (list-ref p1 1))
|
||||
(list-ref p2 0) (- max-y (list-ref p2 1))
|
||||
(list-ref p3 0) (- max-y (list-ref p3 1)))
|
||||
(loop (cdddr points)))]))
|
||||
(send dc draw-path path dx dy))))
|
||||
|
||||
(values (main)
|
||||
positions
|
||||
max-y))
|
||||
|
||||
(define (draw-plain port)
|
||||
|
||||
(define draw (parse-plain port))
|
||||
|
||||
(define f (new frame% [label ""] [width 400] [height 400]))
|
||||
(define c (new canvas% [parent f]
|
||||
[paint-callback
|
||||
(λ (c dc)
|
||||
(draw dc))]))
|
||||
(send (send c get-dc) set-smoothing 'aligned)
|
||||
(send f show #t))
|
||||
|
||||
(define (pixels->inches x) (/ x 72))
|
||||
(define (inches->pixels x) (* x 72))
|
||||
2
collects/redex/private/info.ss
Normal file
2
collects/redex/private/info.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "PLT Redex private"))
|
||||
195
collects/redex/private/loc-wrapper.ss
Normal file
195
collects/redex/private/loc-wrapper.ss
Normal file
|
|
@ -0,0 +1,195 @@
|
|||
|
||||
(module loc-wrapper mzscheme
|
||||
(require (lib "kw.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"term.ss"
|
||||
(lib "contract.ss"))
|
||||
(require-for-syntax "term-fn.ss")
|
||||
|
||||
(define (init-loc-wrapper e line column quoted?)
|
||||
(make-lw e line #f column #f (not quoted?) #f))
|
||||
|
||||
;; lw = (union 'spring loc-wrapper)
|
||||
|
||||
;; e : (union string symbol #f (listof lw))
|
||||
;; line, line-span, column, column-span : number
|
||||
(define-struct lw (e line line-span column column-span unq? metafunction-name) (make-inspector))
|
||||
|
||||
;; build-lw is designed for external consumption
|
||||
(define (build-lw e line line-span column column-span)
|
||||
(make-lw e line line-span column column-span #f #f))
|
||||
|
||||
(define curly-quotes-for-strings (make-parameter #t))
|
||||
|
||||
(define (rewrite-quotes s)
|
||||
(if (curly-quotes-for-strings)
|
||||
(string-append "“"
|
||||
(substring s 1 (- (string-length s) 1))
|
||||
"”")
|
||||
s))
|
||||
|
||||
(define-syntax-set (to-lw to-lw/uq)
|
||||
(define (process-arg stx quote-depth)
|
||||
(define quoted? (quote-depth . > . 0))
|
||||
(define-values (op cl)
|
||||
(if (syntax? stx)
|
||||
(case (syntax-property stx 'paren-shape)
|
||||
[(#\{) (values "{" "}")]
|
||||
[(#\[) (values "[" "]")]
|
||||
[else (values "(" ")")])
|
||||
(values #f #f)))
|
||||
(define (reader-shorthand arg qd-delta mrk)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,mrk
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)
|
||||
'spring
|
||||
#,(process-arg arg (+ quote-depth qd-delta)))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?))
|
||||
(define (handle-sequence qd-delta)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
#,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
|
||||
(init-loc-wrapper #,cl #f #f #,quoted?))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?))
|
||||
(syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
|
||||
[,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
|
||||
[,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
|
||||
[(term a)
|
||||
(if (= quote-depth 0)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
'spring
|
||||
#,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1))
|
||||
'spring)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)
|
||||
(handle-sequence +1))]
|
||||
[(a ...)
|
||||
(handle-sequence 0)]
|
||||
[(a b ... . c)
|
||||
#`(init-loc-wrapper
|
||||
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
|
||||
#,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
|
||||
(init-loc-wrapper #," . " #f #f #,quoted?)
|
||||
#,(process-arg #'c quote-depth)
|
||||
(init-loc-wrapper #,cl #f #f #,quoted?))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]
|
||||
[x
|
||||
(and (identifier? #'x)
|
||||
(term-fn? (syntax-local-value #'x (λ () #f))))
|
||||
#`(make-lw
|
||||
'#,(syntax-e #'x)
|
||||
#,(syntax-line stx)
|
||||
#f
|
||||
#,(syntax-column stx)
|
||||
#f
|
||||
#f
|
||||
#,(if (term-fn-multi-arg? (syntax-local-value #'x))
|
||||
#''multi
|
||||
#''single))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#`(init-loc-wrapper
|
||||
'#,(syntax-e #'x)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]
|
||||
[x
|
||||
#`(init-loc-wrapper
|
||||
#,(let ([base (syntax-e #'x)])
|
||||
(if (string? base)
|
||||
#`(rewrite-quotes #,(format "~s" base))
|
||||
(format "~s" (syntax-e #'x))))
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,quoted?)]))
|
||||
|
||||
(define (to-lw/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
#`(add-spans #,(process-arg #'stx 1))]))
|
||||
(define (to-lw/uq/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
#`(add-spans #,(process-arg #'stx 0))])))
|
||||
|
||||
(define (add-spans lw)
|
||||
(define (add-spans/lw lw line col)
|
||||
(cond
|
||||
[(eq? lw 'spring) (values line col col)]
|
||||
[else
|
||||
(let ([start-line (or (lw-line lw) line)]
|
||||
[start-column (or (lw-column lw) col)])
|
||||
(let-values ([(last-line first-column last-column)
|
||||
(add-spans/obj (lw-e lw) start-line start-column)])
|
||||
(unless (lw-line lw)
|
||||
(set-lw-line! lw line))
|
||||
(set-lw-line-span! lw (- last-line start-line))
|
||||
|
||||
(unless (lw-column lw)
|
||||
(set-lw-column! lw col))
|
||||
(let ([new-col (min (lw-column lw)
|
||||
first-column)])
|
||||
(set-lw-column! lw new-col)
|
||||
(set-lw-column-span! lw (- last-column new-col)))
|
||||
|
||||
(values last-line first-column last-column)))]))
|
||||
(define (add-spans/obj e line col)
|
||||
(cond
|
||||
[(string? e)
|
||||
(values line col (+ col (string-length e)))]
|
||||
[(symbol? e)
|
||||
(values line col (+ col (string-length (symbol->string e))))]
|
||||
[(not e) (values line col col)]
|
||||
[else
|
||||
(let loop ([lws e]
|
||||
[line line]
|
||||
[first-column col]
|
||||
[last-column col]
|
||||
[current-col col])
|
||||
(cond
|
||||
[(null? lws) (values line first-column last-column)]
|
||||
[else
|
||||
(let-values ([(last-line inner-first-column inner-last-column)
|
||||
(add-spans/lw (car lws) line current-col)])
|
||||
(if (= last-line line)
|
||||
(loop (cdr lws)
|
||||
last-line
|
||||
(min inner-first-column first-column)
|
||||
(max inner-last-column last-column)
|
||||
inner-last-column)
|
||||
(loop (cdr lws)
|
||||
last-line
|
||||
(min inner-first-column first-column)
|
||||
inner-last-column
|
||||
inner-last-column)))]))]))
|
||||
|
||||
(add-spans/lw lw #f #f)
|
||||
lw)
|
||||
|
||||
(define pnum (and/c number? (or/c zero? positive?)))
|
||||
|
||||
(provide/contract
|
||||
(struct lw ((e any/c)
|
||||
(line pnum)
|
||||
(line-span pnum)
|
||||
(column pnum)
|
||||
(column-span pnum)
|
||||
(unq? boolean?)
|
||||
(metafunction-name (or/c (symbols 'multi 'single) false/c))))
|
||||
[build-lw (-> any/c pnum pnum pnum pnum lw?)])
|
||||
|
||||
(provide to-lw
|
||||
to-lw/uq
|
||||
curly-quotes-for-strings))
|
||||
43
collects/redex/private/lw-test-util.ss
Normal file
43
collects/redex/private/lw-test-util.ss
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
(module lw-test-util mzscheme
|
||||
(require "loc-wrapper.ss")
|
||||
(provide normalize-lw)
|
||||
|
||||
(define (normalize-lw lw)
|
||||
(define-values (min-line min-column) (find-min-line/col lw))
|
||||
(define (normalize/lw lw)
|
||||
(cond
|
||||
[(lw? lw)
|
||||
(make-lw (normalize/e (lw-e lw))
|
||||
(- (lw-line lw) min-line)
|
||||
(lw-line-span lw)
|
||||
(- (lw-column lw) min-column)
|
||||
(lw-column-span lw)
|
||||
(lw-unq? lw)
|
||||
(lw-metafunction-name lw))]
|
||||
[else lw]))
|
||||
(define (normalize/e e)
|
||||
(cond
|
||||
[(symbol? e) e]
|
||||
[(string? e) e]
|
||||
[else (map normalize/lw e)]))
|
||||
(normalize/lw lw))
|
||||
|
||||
(define (find-min-line/col lw)
|
||||
(define min-line #f)
|
||||
(define min-col #f)
|
||||
(define (find-min/lw lw)
|
||||
(when (lw? lw)
|
||||
(set! min-line (if min-line
|
||||
(min min-line (lw-line lw))
|
||||
(lw-line lw)))
|
||||
(set! min-col (if min-col
|
||||
(min min-col (lw-column lw))
|
||||
(lw-column lw)))
|
||||
(find-min/e (lw-e lw))))
|
||||
(define (find-min/e e)
|
||||
(cond
|
||||
[(symbol? e) (void)]
|
||||
[(string? e) (void)]
|
||||
[else (for-each find-min/lw e)]))
|
||||
(find-min/lw lw)
|
||||
(values min-line min-col)))
|
||||
283
collects/redex/private/lw-test.ss
Normal file
283
collects/redex/private/lw-test.ss
Normal file
|
|
@ -0,0 +1,283 @@
|
|||
#|
|
||||
|
||||
DO NOT TABIFY THIS FILE
|
||||
|
||||
|#
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;;;
|
||||
; ; ; ;
|
||||
; ; ; ;;; ;; ;; ;;; ;;;;;
|
||||
; ; ; ; ; ;; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;; ;;; ;;; ;;; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ; ;;;
|
||||
; ; ; ;
|
||||
; ;;;;; ;;; ; ;; ;;; ;;;;; ;;; ;;;
|
||||
; ; ; ; ;; ; ; ; ; ;
|
||||
; ; ;;;; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;;
|
||||
; ;;; ;;;;;;;;;; ;;;;; ;;;;; ;
|
||||
; ;
|
||||
; ;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ; ;;; ; ;;
|
||||
; ; ; ; ;
|
||||
; ;;;;; ; ;; ;;; ;;;; ;;;;; ;;; ; ;;;
|
||||
; ; ;; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ;;; ; ; ; ;;;;;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;; ;;; ;;; ;;;;; ;;;; ;;;;; ;;;;; ;;;;; ;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(module lw-test mzscheme
|
||||
(require "test-util.ss"
|
||||
"loc-wrapper.ss"
|
||||
"lw-test-util.ss")
|
||||
|
||||
(reset-count)
|
||||
|
||||
(test (normalize-lw (to-lw ()))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw ")" 0 0 1 1))
|
||||
0 0 0 2))
|
||||
|
||||
(test (normalize-lw (to-lw "x"))
|
||||
(build-lw "“x”" 0 0 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw "#f"))
|
||||
(build-lw "“#f”" 0 0 0 4))
|
||||
|
||||
(test (normalize-lw (to-lw #f))
|
||||
(build-lw "#f" 0 0 0 2))
|
||||
|
||||
(test (normalize-lw (to-lw/uq ()))
|
||||
(make-lw (list (make-lw "(" 0 0 0 1 #t #f)
|
||||
(make-lw ")" 0 0 1 1 #t #f))
|
||||
0 0 0 2 #t #f))
|
||||
|
||||
(test (normalize-lw (to-lw (a)))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'a 0 0 1 1)
|
||||
(build-lw ")" 0 0 2 1))
|
||||
0 0 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw (a
|
||||
b)))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'a 0 0 1 1)
|
||||
(build-lw 'b 1 0 1 1)
|
||||
(build-lw ")" 1 0 2 1))
|
||||
0 1 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw (a b)))
|
||||
(build-lw
|
||||
(list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'a 0 0 1 1)
|
||||
(build-lw 'b 0 0 3 1)
|
||||
(build-lw ")" 0 0 4 1))
|
||||
0 0 0 5))
|
||||
|
||||
|
||||
(test (normalize-lw (to-lw (a
|
||||
(b c)
|
||||
d)))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'a 0 0 1 1)
|
||||
(build-lw
|
||||
(list (build-lw "(" 1 0 1 1)
|
||||
(build-lw 'b 1 0 2 1)
|
||||
(build-lw 'c 1 0 4 1)
|
||||
(build-lw ")" 1 0 5 1))
|
||||
1 0 1 5)
|
||||
(build-lw 'd 2 0 1 1)
|
||||
(build-lw ")" 2 0 2 1))
|
||||
0 2 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw (abcdefghijkl
|
||||
b)))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'abcdefghijkl 0 0 1 12)
|
||||
(build-lw 'b 1 0 1 1)
|
||||
(build-lw ")" 1 0 2 1))
|
||||
0 1 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw ((a b)
|
||||
c)))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw
|
||||
(list (build-lw "(" 0 0 1 1)
|
||||
(build-lw 'a 0 0 2 1)
|
||||
(build-lw 'b 0 0 4 1)
|
||||
(build-lw ")" 0 0 5 1))
|
||||
0 0 1 5)
|
||||
(build-lw 'c 1 0 1 1)
|
||||
(build-lw ")" 1 0 2 1))
|
||||
0 1 0 3))
|
||||
|
||||
(test (normalize-lw (to-lw (aaa bbb
|
||||
(ccc
|
||||
ddd)))) ;; <--- the ddd should be lined up under the aaa
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'aaa 0 0 1 3)
|
||||
(build-lw 'bbb 0 0 5 3)
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "(" 1 0 5 1)
|
||||
(build-lw 'ccc 1 0 6 3)
|
||||
(build-lw 'ddd 2 0 1 3)
|
||||
(build-lw ")" 2 0 4 1))
|
||||
1 1 1 4)
|
||||
(build-lw ")" 2 0 5 1))
|
||||
0 2 0 6))
|
||||
|
||||
(test (normalize-lw (to-lw (aaa bbb
|
||||
(ccc
|
||||
ddd ;; <--- the ddd should be lined up under the aaa
|
||||
eee)))) ;; <--- the eee should be lined up under the ccc
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw 'aaa 0 0 1 3)
|
||||
(build-lw 'bbb 0 0 5 3)
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "(" 1 0 5 1)
|
||||
(build-lw 'ccc 1 0 6 3)
|
||||
(build-lw 'ddd 2 0 1 3)
|
||||
(build-lw 'eee 3 0 6 3)
|
||||
(build-lw ")" 3 0 9 1))
|
||||
1 2 1 9)
|
||||
(build-lw ")" 3 0 10 1))
|
||||
0 3 0 11))
|
||||
|
||||
(test (normalize-lw (to-lw ([{}])))
|
||||
(build-lw (list (build-lw "(" 0 0 0 1)
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "[" 0 0 1 1)
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "{" 0 0 2 1)
|
||||
(build-lw "}" 0 0 3 1))
|
||||
0 0 2 2)
|
||||
(build-lw "]" 0 0 4 1))
|
||||
0 0 1 4)
|
||||
(build-lw ")" 0 0 5 1))
|
||||
0 0 0 6))
|
||||
|
||||
(test (normalize-lw (to-lw ,x))
|
||||
(make-lw
|
||||
(list
|
||||
(make-lw "" 0 0 0 0 #f #f)
|
||||
'spring
|
||||
(make-lw 'x 0 0 1 1 #t #f))
|
||||
0 0 0 2 #f #f))
|
||||
|
||||
(test (normalize-lw (to-lw ,@x))
|
||||
(make-lw
|
||||
(list
|
||||
(make-lw "" 0 0 0 0 #f #f)
|
||||
'spring
|
||||
(make-lw 'x 0 0 2 1 #t #f))
|
||||
0 0 0 3 #f #f))
|
||||
|
||||
(test (normalize-lw (to-lw 'x))
|
||||
(make-lw
|
||||
(list
|
||||
(make-lw "'" 0 0 0 1 #f #f)
|
||||
'spring
|
||||
(make-lw 'x 0 0 1 1 #f #f))
|
||||
0 0 0 2 #f #f))
|
||||
|
||||
(test (normalize-lw (to-lw ,(term x)))
|
||||
(make-lw
|
||||
(list
|
||||
(make-lw "" 0 0 0 0 #f #f)
|
||||
'spring
|
||||
(make-lw
|
||||
(list
|
||||
(make-lw "" 0 0 1 0 #t #f)
|
||||
'spring
|
||||
(make-lw 'x 0 0 7 1 #f #f)
|
||||
'spring)
|
||||
0 0 1 7 #t #f))
|
||||
0 0 0 8 #f #f))
|
||||
|
||||
(test (normalize-lw (to-lw (term x)))
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "(" 0 0 0 1)
|
||||
(build-lw 'term 0 0 1 4)
|
||||
(build-lw 'x 0 0 6 1)
|
||||
(build-lw ")" 0 0 7 1))
|
||||
0 0 0 8))
|
||||
|
||||
(test (normalize-lw (to-lw '(term x)))
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "'" 0 0 0 1)
|
||||
'spring
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "(" 0 0 1 1)
|
||||
(build-lw 'term 0 0 2 4)
|
||||
(build-lw 'x 0 0 7 1)
|
||||
(build-lw ")" 0 0 8 1))
|
||||
0
|
||||
0
|
||||
1
|
||||
8))
|
||||
0 0 0 9))
|
||||
|
||||
(test (normalize-lw (to-lw ''x))
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "'" 0 0 0 1)
|
||||
'spring
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "'" 0 0 1 1)
|
||||
'spring
|
||||
(build-lw 'x 0 0 2 1))
|
||||
0
|
||||
0
|
||||
1
|
||||
2))
|
||||
0 0 0 3))
|
||||
|
||||
;; this one seems suspicious: why does the second comma start at 1 instead of 0?
|
||||
;; rendering seems to work, however, so we'll go with it ..
|
||||
(test (normalize-lw (to-lw ,,x))
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "" 0 0 0 0)
|
||||
'spring
|
||||
(make-lw
|
||||
(list
|
||||
(make-lw "," 0 0 1 1 #t #f)
|
||||
'spring
|
||||
(make-lw 'x 0 0 2 1 #t #f))
|
||||
0 0 1 2
|
||||
#t #f))
|
||||
0 0 0 3))
|
||||
|
||||
(print-tests-passed "lw-test.ss"))
|
||||
|
||||
799
collects/redex/private/matcher-test.ss
Normal file
799
collects/redex/private/matcher-test.ss
Normal file
|
|
@ -0,0 +1,799 @@
|
|||
(module matcher-test mzscheme
|
||||
(require "matcher.ss"
|
||||
(only "test-util.ss" equal/bindings?)
|
||||
(lib "list.ss"))
|
||||
|
||||
(define hole (make-hole/intern none))
|
||||
(define (false-hole/name name) (make-hole/intern name #t)) ;; this used to be a #f
|
||||
|
||||
(error-print-width 500)
|
||||
|
||||
(define (make-test-mtch a b c) (make-mtch a (build-flat-context b) c))
|
||||
|
||||
(define (test)
|
||||
(print-struct #t)
|
||||
(test-empty 'any 1 (list (make-test-mtch (make-bindings (list (make-bind 'any 1))) 1 none)))
|
||||
(test-empty 'any 'true (list (make-test-mtch (make-bindings (list (make-bind 'any 'true))) 'true none)))
|
||||
(test-empty 'any "a" (list (make-test-mtch (make-bindings (list (make-bind 'any "a"))) "a" none)))
|
||||
(test-empty 'any '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'any '(a b)))) '(a b) none)))
|
||||
(test-empty 'any #t (list (make-test-mtch (make-bindings (list (make-bind 'any #t))) #t none)))
|
||||
(test-empty 1 1 (list (make-test-mtch (make-bindings null) 1 none)))
|
||||
(test-empty 1 '() #f)
|
||||
(test-empty 99999999999999999999999999999999999999999999999
|
||||
99999999999999999999999999999999999999999999999
|
||||
(list (make-test-mtch (make-bindings null)
|
||||
99999999999999999999999999999999999999999999999
|
||||
none)))
|
||||
(test-empty 99999999999999999999999999999999999999999999999
|
||||
'()
|
||||
#f)
|
||||
(test-empty 'x 'x (list (make-test-mtch (make-bindings null) 'x none)))
|
||||
(test-empty 'x '() #f)
|
||||
(test-empty 1 2 #f)
|
||||
(test-empty "a" "b" #f)
|
||||
(test-empty "a" '(x) #f)
|
||||
(test-empty "a" '() #f)
|
||||
(test-empty "a" "a" (list (make-test-mtch (make-bindings null) "a" none)))
|
||||
(test-empty 'number 1 (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) 1 none)))
|
||||
(test-empty 'number 'x #f)
|
||||
(test-empty 'number '() #f)
|
||||
(test-empty 'string "a" (list (make-test-mtch (make-bindings (list (make-bind 'string "a"))) "a" none)))
|
||||
(test-empty 'string 1 #f)
|
||||
(test-empty 'string '() #f)
|
||||
(test-empty 'variable 'x (list (make-test-mtch (make-bindings (list (make-bind 'variable 'x))) 'x none)))
|
||||
(test-empty 'variable 1 #f)
|
||||
(test-empty '(variable-except x) 1 #f)
|
||||
(test-empty '(variable-except x) 'x #f)
|
||||
(test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none)))
|
||||
(test-empty '(variable-prefix x:) 'x: (list (make-test-mtch (make-bindings null) 'x: none)))
|
||||
(test-empty '(variable-prefix x:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none)))
|
||||
(test-empty '(variable-prefix x:) ': #f)
|
||||
(test-empty '(variable-prefix x:) '() #f)
|
||||
|
||||
(test-empty 'hole 1 #f)
|
||||
(test-empty '(hole hole-name) 1 #f)
|
||||
(test-empty `hole
|
||||
hole
|
||||
(list (make-test-mtch (make-bindings (list)) hole none)))
|
||||
(test-empty `(hole #f)
|
||||
hole
|
||||
(list (make-test-mtch (make-bindings (list)) hole none)))
|
||||
(test-empty '(hole hole-name)
|
||||
hole
|
||||
#f)
|
||||
|
||||
|
||||
(test-empty '(hole a-hole-name)
|
||||
(make-hole/intern 'a-hole-name)
|
||||
(list (make-test-mtch (make-bindings (list)) (make-hole/intern 'a-hole-name) none)))
|
||||
|
||||
(test-empty '(hole #f)
|
||||
hole
|
||||
(list (make-test-mtch (make-bindings (list)) hole none)))
|
||||
|
||||
(test-empty '(in-named-hole b ((hole a) (hole b)) x)
|
||||
`(,(make-hole/intern 'a) x)
|
||||
(list (make-test-mtch (make-bindings (list)) `(,(make-hole/intern 'a) x) none)))
|
||||
|
||||
(test-empty '(in-hole (name E_1 ((hide-hole hole) hole)) x)
|
||||
`(,hole x)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'E_1 `(,hole ,hole))))
|
||||
`(x ,hole)
|
||||
none)))
|
||||
|
||||
|
||||
|
||||
(test-empty '(name x number) 1 (list (make-test-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'number 1))) 1 none)))
|
||||
(test-empty 'number_x 1 (list (make-test-mtch (make-bindings (list (make-bind 'number_x 1))) 1 none)))
|
||||
(test-empty 'string_y "b" (list (make-test-mtch (make-bindings (list (make-bind 'string_y "b"))) "b" none)))
|
||||
(test-empty 'any_z '(a b) (list (make-test-mtch (make-bindings (list (make-bind 'any_z '(a b)))) '(a b) none)))
|
||||
|
||||
(test-empty '(name x_!_1 number) 1 (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) 1 none)))
|
||||
(test-empty '((name x_!_1 number) (name x_!_1 number)) '(1 1) #f)
|
||||
(test-empty '((name x_!_1 number_a) (name x_!_1 number_b)) '(1 2)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'number_a 1)
|
||||
(make-bind 'number_b 2)))
|
||||
'(1 2)
|
||||
none)))
|
||||
(test-empty '(number_!_1 number_!_1) '(1 1) #f)
|
||||
(test-empty '(number_!_1 number_!_1) '(1 2) (list (make-test-mtch (make-bindings (list)) '(1 2) none)))
|
||||
(test-empty '(number_!_1 ...) '(1 2) (list (make-test-mtch (make-bindings (list)) '(1 2) none)))
|
||||
(test-empty '(number_!_1 ...) '(1 2 3 4 5) (list (make-test-mtch (make-bindings (list)) '(1 2 3 4 5) none)))
|
||||
(test-empty '(number_!_1 ...) '(1 2 3 1 5) (list (make-test-mtch (make-bindings (list)) '(1 2 3 1 5) none)))
|
||||
(test-empty '((number_!_1 ...) (number_!_1 ...))
|
||||
'((1 2 3 1 5) (1 2 3 1 5))
|
||||
#f)
|
||||
(test-empty '((number_!_1 ...) (number_!_1 ...))
|
||||
'((17 2 3 1 5) (1 2 3 1 5))
|
||||
(list (make-test-mtch (make-bindings (list)) '((17 2 3 1 5) (1 2 3 1 5)) none)))
|
||||
|
||||
(test-ellipses '(a) '(a))
|
||||
(test-ellipses '(a ...) `(,(make-repeat 'a '() #f #f)))
|
||||
(test-ellipses '((a ...) ...) `(,(make-repeat '(a ...) '() #f #f)))
|
||||
(test-ellipses '(a ... b c ...) `(,(make-repeat 'a '() #f #f) b ,(make-repeat 'c '() #f #f)))
|
||||
(test-ellipses '((name x a) ...) `(,(make-repeat '(name x a) (list (make-bind 'x '())) #f #f)))
|
||||
(test-ellipses '((name x (a ...)) ...)
|
||||
`(,(make-repeat '(name x (a ...)) (list (make-bind 'x '())) #f #f)))
|
||||
(test-ellipses '(((name x a) ...) ...)
|
||||
`(,(make-repeat '((name x a) ...) (list (make-bind 'x '())) #f #f)))
|
||||
(test-ellipses '((1 (name x a)) ...)
|
||||
`(,(make-repeat '(1 (name x a)) (list (make-bind 'x '())) #f #f)))
|
||||
(test-ellipses '((any (name x a)) ...)
|
||||
`(,(make-repeat '(any (name x a)) (list (make-bind 'x '())
|
||||
(make-bind 'any '()))
|
||||
#f #f)))
|
||||
(test-ellipses '((number (name x a)) ...)
|
||||
`(,(make-repeat '(number (name x a)) (list (make-bind 'x '())
|
||||
(make-bind 'number '()))
|
||||
#f #f)))
|
||||
(test-ellipses '((variable (name x a)) ...)
|
||||
`(,(make-repeat '(variable (name x a)) (list (make-bind 'x '())
|
||||
(make-bind 'variable '()))
|
||||
#f #f)))
|
||||
(test-ellipses '(((name x a) (name y b)) ...)
|
||||
`(,(make-repeat '((name x a) (name y b)) (list (make-bind 'y '()) (make-bind 'x '())) #f #f)))
|
||||
(test-ellipses '((name x (name y b)) ...)
|
||||
`(,(make-repeat '(name x (name y b)) (list (make-bind 'y '()) (make-bind 'x '())) #f #f)))
|
||||
(test-ellipses '((in-hole (name x a) (name y b)) ...)
|
||||
`(,(make-repeat '(in-hole (name x a) (name y b))
|
||||
(list (make-bind 'x '()) (make-bind 'y '())) #f #f)))
|
||||
|
||||
(test-ellipses '(a ..._1)
|
||||
`(,(make-repeat 'a (list) '..._1 #f)))
|
||||
(test-ellipses '(a ..._!_1)
|
||||
`(,(make-repeat 'a (list) '..._!_1 #t)))
|
||||
|
||||
(test-empty '() '() (list (make-test-mtch (make-bindings null) '() none)))
|
||||
(test-empty '(a) '(a) (list (make-test-mtch (make-bindings null) '(a) none)))
|
||||
(test-empty '(a) '(b) #f)
|
||||
(test-empty '(a b) '(a b) (list (make-test-mtch (make-bindings null) '(a b) none)))
|
||||
(test-empty '(a b) '(a c) #f)
|
||||
(test-empty '() 1 #f)
|
||||
(test-empty '(#f x) '(#f x) (list (make-test-mtch (make-bindings null) '(#f x) none)))
|
||||
(test-empty '(#f (name y any)) '(#f) #f)
|
||||
(test-empty '(in-hole (z hole) a) '(z a) (list (make-test-mtch (make-bindings (list)) '(z a) none)))
|
||||
(test-empty '(in-hole (z hole) (in-hole (x hole) a))
|
||||
'(z (x a))
|
||||
(list (make-test-mtch (make-bindings (list)) '(z (x a)) none)))
|
||||
|
||||
(run-test/cmp 'in-hole-zero-holes
|
||||
(with-handlers ([exn:fail? (λ (e) (regexp-match #rx"zero holes" (exn-message e)))])
|
||||
(test-empty '(in-hole (1 2) 2) '(1 2) 'never-gets-here)
|
||||
'should-have-raised-an-exception)
|
||||
'("zero holes")
|
||||
equal?)
|
||||
|
||||
|
||||
(test-empty '(in-named-hole h1 (z (hole h1)) a)
|
||||
'(z a)
|
||||
(list (make-test-mtch (make-bindings (list)) '(z a) none)))
|
||||
|
||||
(test-empty '(in-named-hole h1 (z (hole h1)) a) '(z a) (list (make-test-mtch (make-bindings (list)) '(z a) none)))
|
||||
(test-empty '(in-named-hole c (any (hole c)) y)
|
||||
'(x y)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'any 'x))) '(x y) none)))
|
||||
(test-empty '(in-named-hole a (in-named-hole b (x (hole b)) (hole a)) y)
|
||||
'(x y)
|
||||
(list (make-test-mtch (make-bindings (list)) '(x y) none)))
|
||||
(test-empty '(in-hole (in-hole (x hole) hole) y)
|
||||
'(x y)
|
||||
(list (make-test-mtch (make-bindings (list)) '(x y) none)))
|
||||
|
||||
(test-empty '(number number) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'number 1))) '(1 1) none)))
|
||||
(test-empty '((name x number) (name x number)) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'x 1) (make-bind 'number 1))) '(1 1) none)))
|
||||
(test-empty '((name x number_q) (name x number_r)) '(1 1) (list (make-test-mtch (make-bindings (list (make-bind 'x 1)
|
||||
(make-bind 'number_q 1)
|
||||
(make-bind 'number_r 1)))
|
||||
'(1 1)
|
||||
none)))
|
||||
(test-empty '(number number) '(1 2) #f)
|
||||
(test-empty '((name x number) (name x number)) '(1 2) #f)
|
||||
(test-empty '((name x number_q) (name x number_r)) '(1 2) #f)
|
||||
|
||||
(test-empty '(a ...) '() (list (make-test-mtch (make-bindings empty) '() none)))
|
||||
(test-empty '(a ...) '(a) (list (make-test-mtch (make-bindings empty) '(a) none)))
|
||||
(test-empty '(a ...) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none)))
|
||||
(test-empty '((name x a) ...) '() (list (make-test-mtch (make-bindings (list (make-bind 'x '()))) '() none)))
|
||||
(test-empty '((name x a) ...) '(a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a)))) '(a) none)))
|
||||
(test-empty '((name x a) ...) '(a a) (list (make-test-mtch (make-bindings (list (make-bind 'x '(a a)))) '(a a) none)))
|
||||
|
||||
(test-empty '(b ... a ...) '() (list (make-test-mtch (make-bindings empty) '() none)))
|
||||
(test-empty '(b ... a ...) '(a) (list (make-test-mtch (make-bindings empty) '(a) none)))
|
||||
(test-empty '(b ... a ...) '(b) (list (make-test-mtch (make-bindings empty) '(b) none)))
|
||||
(test-empty '(b ... a ...) '(b a) (list (make-test-mtch (make-bindings empty) '(b a) none)))
|
||||
(test-empty '(b ... a ...) '(b b a a) (list (make-test-mtch (make-bindings empty) '(b b a a) none)))
|
||||
(test-empty '(b ... a ...) '(a a) (list (make-test-mtch (make-bindings empty) '(a a) none)))
|
||||
(test-empty '(b ... a ...) '(b b) (list (make-test-mtch (make-bindings empty) '(b b) none)))
|
||||
|
||||
(test-empty '(a ..._1 a ..._2)
|
||||
'(a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind '..._1 1) (make-bind '..._2 0))) '(a) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind '..._1 0) (make-bind '..._2 1))) '(a) none)))
|
||||
(test-empty '(a ..._1 a ..._1) '(a) #f)
|
||||
(test-empty '(a ..._1 a ..._1)
|
||||
'(a a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind '..._1 1))) '(a a) none)))
|
||||
|
||||
(test-empty '((name x a) ..._!_1 (name y a) ..._!_1)
|
||||
'(a a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '()) (make-bind 'y '(a a)))) '(a a) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'x '(a a)) (make-bind 'y '()))) '(a a) none)))
|
||||
|
||||
(test-empty '((name y b) ... (name x a) ...) '()
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '())
|
||||
(make-bind 'y '())))
|
||||
'()
|
||||
none)))
|
||||
(test-empty '((name y b) ... (name x a) ...) '(a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '(a))
|
||||
(make-bind 'y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-empty '((name y b) ... (name x a) ...) '(b)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '())
|
||||
(make-bind 'y '(b))))
|
||||
'(b)
|
||||
none)))
|
||||
(test-empty '((name y b) ... (name x a) ...) '(b b a a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '(a a))
|
||||
(make-bind 'y '(b b))))
|
||||
'(b b a a)
|
||||
none)))
|
||||
(test-empty '((name y a) ... (name x a) ...) '(a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '())
|
||||
(make-bind 'y '(a))))
|
||||
'(a)
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'x '(a))
|
||||
(make-bind 'y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-empty '((name y a) ... (name x a) ...) '(a a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '())
|
||||
(make-bind 'y '(a a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'x '(a))
|
||||
(make-bind 'y '(a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'x '(a a))
|
||||
(make-bind 'y '())))
|
||||
'(a a)
|
||||
none)))
|
||||
|
||||
(test-ab '(bb_y ... aa_x ...) '()
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa_x '())
|
||||
(make-bind 'bb_y '())))
|
||||
'()
|
||||
none)))
|
||||
(test-ab '(bb_y ... aa_x ...) '(a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a))
|
||||
(make-bind 'bb_y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-ab '(bb_y ... aa_x ...) '(b)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa_x '())
|
||||
(make-bind 'bb_y '(b))))
|
||||
'(b)
|
||||
none)))
|
||||
(test-ab '(bb_y ... aa_x ...) '(b b a a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa_x '(a a))
|
||||
(make-bind 'bb_y '(b b))))
|
||||
'(b b a a)
|
||||
none)))
|
||||
(test-ab '(aa_y ... aa_x ...) '(a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa_x '())
|
||||
(make-bind 'aa_y '(a))))
|
||||
'(a)
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'aa_x '(a))
|
||||
(make-bind 'aa_y '())))
|
||||
'(a)
|
||||
none)))
|
||||
(test-ab '(aa_y ... aa_x ...) '(a a)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa_x '())
|
||||
(make-bind 'aa_y '(a a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'aa_x '(a))
|
||||
(make-bind 'aa_y '(a))))
|
||||
'(a a)
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'aa_x '(a a))
|
||||
(make-bind 'aa_y '())))
|
||||
'(a a)
|
||||
none)))
|
||||
|
||||
(test-empty '((name x number) ...) '(1 2) (list (make-test-mtch (make-bindings (list (make-bind 'x '(1 2)) (make-bind 'number '(1 2)))) '(1 2) none)))
|
||||
|
||||
(test-empty '(a ...) '(b) #f)
|
||||
(test-empty '(a ... b ...) '(c) #f)
|
||||
(test-empty '(a ... b) '(b c) #f)
|
||||
(test-empty '(a ... b) '(a b c) #f)
|
||||
|
||||
(test-empty '((name x any)
|
||||
((name x number) ...))
|
||||
'((1 1) (1 1))
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x '(1 1))
|
||||
(make-bind 'any '(1 1))
|
||||
(make-bind 'number '(1 1))))
|
||||
'((1 1) (1 1))
|
||||
none)))
|
||||
|
||||
(test-empty '(number ...) '()
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'number '()))) '() none)))
|
||||
(test-ab '(aa ...) '()
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'aa '()))) '() none)))
|
||||
|
||||
;; testing block-in-hole
|
||||
(test-empty '(hide-hole a) 'b #f)
|
||||
(test-empty '(hide-hole a) 'a (list (make-test-mtch (make-bindings '()) 'a none)))
|
||||
(test-empty '(hide-hole a) '(block-in-hole a) #f)
|
||||
(test-empty '(in-hole (x (hide-hole hole)) 1) '(x 1) #f)
|
||||
(test-empty '(in-hole (x hole) 1) '(x 1) (list (make-test-mtch (make-bindings '()) '(x 1) none)))
|
||||
(test-empty '(in-hole ((hole #f) (hide-hole hole)) junk)
|
||||
'(junk junk2)
|
||||
#f)
|
||||
|
||||
(test-xab 'lsts '() (list (make-test-mtch (make-bindings (list (make-bind 'lsts '()))) '() none)))
|
||||
(test-xab 'lsts '(x) (list (make-test-mtch (make-bindings (list (make-bind 'lsts '(x)))) '(x) none)))
|
||||
(test-xab 'lsts 'x (list (make-test-mtch (make-bindings (list (make-bind 'lsts 'x))) 'x none)))
|
||||
(test-xab 'lsts #f (list (make-test-mtch (make-bindings (list (make-bind 'lsts #f))) #f none)))
|
||||
(test-xab 'split-out '1 (list (make-test-mtch (make-bindings (list (make-bind 'split-out 1))) '1 none)))
|
||||
|
||||
(test-xab 'exp 1 (list (make-test-mtch (make-bindings (list (make-bind 'exp 1))) 1 none)))
|
||||
(test-xab 'exp '(+ 1 2) (list (make-test-mtch (make-bindings (list (make-bind 'exp '(+ 1 2)))) '(+ 1 2) none)))
|
||||
(test-xab '(in-hole ctxt any)
|
||||
'1
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'ctxt hole) (make-bind 'any 1))) 1 none)))
|
||||
(test-xab '(in-hole ctxt (name x any))
|
||||
'1
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'ctxt hole) (make-bind 'x 1) (make-bind 'any 1))) 1 none)))
|
||||
(test-xab '(in-hole (name c ctxt) (name x any))
|
||||
'(+ 1 2)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context hole))
|
||||
(make-bind 'c (build-context hole))
|
||||
(make-bind 'x '(+ 1 2))
|
||||
(make-bind 'any '(+ 1 2))))
|
||||
'(+ 1 2) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context `(+ ,hole 2)))
|
||||
(make-bind 'c (build-context `(+ ,hole 2)))
|
||||
(make-bind 'x 1)
|
||||
(make-bind 'any 1)))
|
||||
'(+ 1 2) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'ctxt (build-context `(+ 1 ,hole)))
|
||||
(make-bind 'c (build-context `(+ 1 ,hole)))
|
||||
(make-bind 'x 2)
|
||||
(make-bind 'any 2)))
|
||||
'(+ 1 2) none)))
|
||||
(test-xab '(in-hole (name c ctxt) (name i (+ number_1 number_2)))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
(list (make-test-mtch
|
||||
(make-bindings (list (make-bind 'i '(+ 1 2))
|
||||
(make-bind 'number_1 1)
|
||||
(make-bind 'number_2 2)
|
||||
(make-bind 'ctxt (build-context `(+ ,hole (+ 3 4))))
|
||||
(make-bind 'c (build-context `(+ ,hole (+ 3 4))))))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'i '(+ 3 4))
|
||||
(make-bind 'number_1 3)
|
||||
(make-bind 'number_2 4)
|
||||
(make-bind 'ctxt `(+ (+ 1 2) ,hole))
|
||||
(make-bind 'c `(+ (+ 1 2) ,hole))))
|
||||
'(+ (+ 1 2) (+ 3 4))
|
||||
none)))
|
||||
|
||||
(test-empty '(in-hole ((z hole)) (name x any))
|
||||
'((z a))
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x 'a) (make-bind 'any 'a))) '((z a)) none)))
|
||||
(test-empty '(in-hole (name c (z ... hole z ...)) any)
|
||||
'(z z)
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c `(z ,hole)) (make-bind 'any 'z))) '(z z) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c `(,hole z)) (make-bind 'any 'z))) '(z z) none)))
|
||||
(test-empty '(in-hole (name c (z ... hole z ...)) any)
|
||||
'(z z z)
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c `(z z ,hole)) (make-bind 'any 'z))) '(z z z) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c `(z ,hole z)) (make-bind 'any 'z))) '(z z z) none)
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c `(,hole z z)) (make-bind 'any 'z))) '(z z z) none)))
|
||||
|
||||
(test-empty '(z (in-hole (name c (z hole)) a))
|
||||
'(z (z a))
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c `(z ,hole))))
|
||||
'(z (z a))
|
||||
none)))
|
||||
|
||||
(test-empty '(a (in-hole (name c1 (b (in-hole (name c2 (c hole)) d) hole)) e))
|
||||
'(a (b (c d) e))
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c2 `(c ,hole))
|
||||
(make-bind 'c1 `(b (c d) ,hole))))
|
||||
'(a (b (c d) e))
|
||||
none)))
|
||||
|
||||
(test-empty '(in-hole (in-hole hole hole) a)
|
||||
'a
|
||||
(list (make-test-mtch (make-bindings (list)) 'a none)))
|
||||
|
||||
(test-empty '(a (b (in-hole (name c1 (in-hole (name c2 (c hole)) (d hole))) e)))
|
||||
'(a (b (c (d e))))
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'c1 `(c (d ,hole)))
|
||||
(make-bind 'c2 `(c ,hole))))
|
||||
'(a (b (c (d e))))
|
||||
none)))
|
||||
|
||||
(test-empty `(+ 1 (side-condition any ,(lambda (bindings) #t)))
|
||||
'(+ 1 b)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'any 'b))) '(+ 1 b) none)))
|
||||
(test-empty `(+ 1 (side-condition any ,(lambda (bindings) #f)))
|
||||
'(+ 1 b)
|
||||
#f)
|
||||
|
||||
(test-empty `(+ 1 (side-condition b ,(lambda (bindings) #t)))
|
||||
'(+ 1 b)
|
||||
(list (make-test-mtch (make-bindings '()) '(+ 1 b) none)))
|
||||
(test-empty `(+ 1 (side-condition a ,(lambda (bindings) #t)))
|
||||
'(+ 1 b)
|
||||
#f)
|
||||
|
||||
(test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)))
|
||||
'a
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'x 'a)
|
||||
(make-bind 'any 'a)))
|
||||
'a
|
||||
none)))
|
||||
|
||||
(test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a))))
|
||||
'(+ 1 a)
|
||||
(list
|
||||
(make-test-mtch (make-bindings (list (make-bind 'x 'a)
|
||||
(make-bind 'any 'a)))
|
||||
'(+ 1 a)
|
||||
none)))
|
||||
|
||||
(test-empty `(side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a)))
|
||||
'b
|
||||
#f)
|
||||
|
||||
(test-empty `(+ 1 (side-condition (name x any) ,(lambda (bindings) (eq? (lookup-binding bindings 'x) 'a))))
|
||||
'(+ 1 b)
|
||||
#f)
|
||||
|
||||
(test-xab 'exp_1
|
||||
'(+ 1 2)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'exp_1 '(+ 1 2)))) '(+ 1 2) none)))
|
||||
(test-xab '(exp_1 exp_2)
|
||||
'((+ 1 2) (+ 3 4))
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'exp_1 '(+ 1 2)) (make-bind 'exp_2 '(+ 3 4))))
|
||||
'((+ 1 2) (+ 3 4))
|
||||
none)))
|
||||
(test-xab '(exp_1 exp_1)
|
||||
'((+ 1 2) (+ 3 4))
|
||||
#f)
|
||||
(test-xab 'nesting-names
|
||||
'b
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'nesting-names 'b))) 'b none)))
|
||||
(test-xab 'nesting-names
|
||||
'(a b)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a b)))) '(a b) none)))
|
||||
(test-xab 'nesting-names
|
||||
'(a (a b))
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a (a b))))) '(a (a b)) none)))
|
||||
(test-xab '((name x a) nesting-names)
|
||||
'(a (a (a b)))
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'x 'a)
|
||||
(make-bind 'nesting-names '(a (a b)))))
|
||||
'(a (a (a b))) none)))
|
||||
(test-xab 'nesting-names
|
||||
'(a (a (a (a b))))
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'nesting-names '(a (a (a (a b)))))))
|
||||
'(a (a (a (a b)))) none)))
|
||||
|
||||
(test-xab 'same-in-nt
|
||||
'(x x)
|
||||
(list (make-test-mtch (make-bindings (list (make-bind 'same-in-nt '(x x)))) '(x x) none)))
|
||||
(test-xab 'same-in-nt
|
||||
'(x y)
|
||||
#f)
|
||||
|
||||
(test-xab '(in-hole (cross forever-list) 1)
|
||||
'(a b c)
|
||||
#f)
|
||||
|
||||
(test-xab '(in-hole (cross forever-list) 1)
|
||||
'(1 x x)
|
||||
(list (make-test-mtch (make-bindings '()) '(1 x x) none)))
|
||||
|
||||
(test-xab '(in-hole (cross forever-list) 1)
|
||||
'(x 1 x)
|
||||
(list (make-test-mtch (make-bindings '()) '(x 1 x) none)))
|
||||
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole ec-multi (+ number number))
|
||||
'(+ 1 2)
|
||||
(list (make-bindings (list (make-bind 'hole (make-hole-binding '(+ 1 2) '() #f))))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole ec-multi (+ number number))
|
||||
'(+ 1 (+ 5 6))
|
||||
(list (make-bindings (list (make-bind 'hole (make-hole-binding '(+ 5 6) '(cdr cdr car) #f))))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole ec-multi (+ number number))
|
||||
'(+ (+ (+ 1 2) 3) 4)
|
||||
(list (make-bindings (list (make-bind 'hole (make-hole-binding '(+ 1 2) '(cdr car cdr car) #f))))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole ec-multi (+ number number))
|
||||
'(+ (+ 3 (+ 1 2)) 4)
|
||||
(list (make-bindings (list (make-bind 'hole (make-hole-binding '(+ 1 2) '(cdr car cdr cdr car) #f))))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole ec-multi (+ number number))
|
||||
'(+ (+ (+ 1 2) (+ 3 4)) (+ 5 6))
|
||||
(list (make-bindings (list (make-bind 'hole (make-hole-binding '(+ 5 6) '(cdr cdr car) #f))))
|
||||
(make-bindings (list (make-bind 'hole (make-hole-binding '(+ 1 2) '(cdr car cdr car) #f))))
|
||||
(make-bindings (list (make-bind 'hole (make-hole-binding '(+ 3 4) '(cdr car cdr cdr car) #f))))))
|
||||
|
||||
(test-xab '(in-hole (cross simple) g)
|
||||
'g
|
||||
(list (make-mtch (make-bindings (list)) 'g none)))
|
||||
|
||||
(test-xab 'var '+ #f)
|
||||
(test-xab 'var 'anunusedvariable (list (make-mtch (make-bindings (list (make-bind 'var 'anunusedvariable))) 'anunusedvariable none)))
|
||||
(test-xab 'var 'exp (list (make-mtch (make-bindings (list (make-bind 'var 'exp))) 'exp none)))
|
||||
(test-xab 'var 'exp_x (list (make-mtch (make-bindings (list (make-bind 'var 'exp_x))) 'exp_x none)))
|
||||
|
||||
(test-xab 'underscore '(+ 1 2) (list (make-mtch (make-bindings (list (make-bind 'underscore '(+ 1 2)))) '(+ 1 2) none)))
|
||||
(test-xab 'underscore '2 (list (make-mtch (make-bindings (list (make-bind 'underscore 2))) 2 none)))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language1
|
||||
(build-compatible-context-language
|
||||
(mk-hasheq '((exp . ()) (ctxt . ())))
|
||||
(list (make-nt 'exp
|
||||
(list (make-rhs '(+ exp exp) '())
|
||||
(make-rhs 'number '())))
|
||||
(make-nt 'ctxt
|
||||
(list (make-rhs '(+ ctxt exp) '())
|
||||
(make-rhs '(+ exp ctxt) '())
|
||||
(make-rhs 'hole '())))))
|
||||
(list
|
||||
(make-nt 'exp-exp
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs `(+ (cross exp-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross exp-exp)) '())))
|
||||
(make-nt 'exp-ctxt
|
||||
(list (make-rhs `(+ (cross exp-ctxt) exp) '())
|
||||
(make-rhs `(+ ctxt (cross exp-exp)) '())
|
||||
(make-rhs `(+ (cross exp-exp) ctxt) '())
|
||||
(make-rhs `(+ exp (cross exp-ctxt)) '())))
|
||||
(make-nt 'ctxt-exp
|
||||
(list (make-rhs `(+ (cross ctxt-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross ctxt-exp)) '())))
|
||||
(make-nt 'ctxt-ctxt
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs `(+ (cross ctxt-ctxt) exp) '())
|
||||
(make-rhs `(+ ctxt (cross ctxt-exp)) '())
|
||||
(make-rhs `(+ (cross ctxt-exp) ctxt) '())
|
||||
(make-rhs `(+ exp (cross ctxt-ctxt)) '())))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language2
|
||||
(build-compatible-context-language
|
||||
(mk-hasheq '((m . ()) (v . ())))
|
||||
(list (make-nt 'm (list (make-rhs '(m m) '()) (make-rhs '(+ m m) '()) (make-rhs 'v '())))
|
||||
(make-nt 'v (list (make-rhs 'number '()) (make-rhs '(lambda (x) m) '())))))
|
||||
(list
|
||||
(make-nt 'm-m
|
||||
(list
|
||||
(make-rhs 'hole '())
|
||||
(make-rhs (list (list 'cross 'm-m) 'm) '())
|
||||
(make-rhs (list 'm (list 'cross 'm-m)) '())
|
||||
(make-rhs (list '+ (list 'cross 'm-m) 'm) '())
|
||||
(make-rhs (list '+ 'm (list 'cross 'm-m)) '())
|
||||
(make-rhs (list 'cross 'm-v) '())))
|
||||
(make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)) '())))
|
||||
(make-nt 'v-m
|
||||
(list
|
||||
(make-rhs (list (list 'cross 'v-m) 'm) '())
|
||||
(make-rhs (list 'm (list 'cross 'v-m)) '())
|
||||
(make-rhs (list '+ (list 'cross 'v-m) 'm) '())
|
||||
(make-rhs (list '+ 'm (list 'cross 'v-m)) '())
|
||||
(make-rhs (list 'cross 'v-v) '())))
|
||||
(make-nt 'v-v (list (make-rhs 'hole '()) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)) '())))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language3
|
||||
(build-compatible-context-language
|
||||
(mk-hasheq '((m . ()) (seven . ())))
|
||||
(list (make-nt 'm (list (make-rhs '(m seven m) '()) (make-rhs 'number '())))
|
||||
(make-nt 'seven (list (make-rhs 7 '())))))
|
||||
`(,(make-nt
|
||||
'm-m
|
||||
`(,(make-rhs 'hole '()) ,(make-rhs `((cross m-m) seven m) '()) ,(make-rhs `(m (cross m-seven) m) '()) ,(make-rhs `(m seven (cross m-m)) '())))
|
||||
,(make-nt 'm-seven `())
|
||||
,(make-nt
|
||||
'seven-m
|
||||
`(,(make-rhs `((cross seven-m) seven m) '()) ,(make-rhs `(m (cross seven-seven) m) '()) ,(make-rhs `(m seven (cross seven-m)) '())))
|
||||
,(make-nt 'seven-seven `(,(make-rhs 'hole '())))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole (cross exp) (+ number number))
|
||||
'(+ (+ 1 2) 3)
|
||||
(list (make-bindings (list (make-bind 'hole (make-hole-binding (list '+ 1 2) (list 'cdr 'car) #f))))))
|
||||
|
||||
(run-test/cmp 'split-underscore1 (split-underscore 'a_1) 'a eq?)
|
||||
(run-test/cmp 'split-underscore2 (split-underscore 'a_!_1) 'a eq?)
|
||||
(run-test/cmp 'split-underscore3
|
||||
(with-handlers ([exn:fail? (λ (e) (cadr (regexp-match #rx"^([^:]+):" (exn-message e))))])
|
||||
(split-underscore 'a_b_1))
|
||||
"compile-pattern"
|
||||
equal?)
|
||||
|
||||
(cond
|
||||
[(= failures 0)
|
||||
(fprintf (current-error-port) "matcher-test.ss: all ~a tests passed.\n" test-count)]
|
||||
[else
|
||||
(fprintf (current-error-port) "matcher-test.ss: ~a test~a failed.\n"
|
||||
failures
|
||||
(if (= failures 1)
|
||||
""
|
||||
"s"))]))
|
||||
|
||||
;; mk-hasheq : (listof (cons sym any)) -> hash-table
|
||||
;; builds a hash table that has the bindings in assoc-list
|
||||
(define (mk-hasheq assoc-list)
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(hash-table-put! ht (car a) (cdr a)))
|
||||
assoc-list)
|
||||
ht))
|
||||
|
||||
;; test-empty : sexp[pattern] sexp[term] answer -> void
|
||||
;; returns #t if pat matching exp with the empty language produces ans.
|
||||
(define (test-empty pat exp ans)
|
||||
(run-match-test
|
||||
`(match-pattern (compile-pattern (compile-language 'pict-stuff-not-used '() '()) ',pat #t) ',exp)
|
||||
(match-pattern
|
||||
(compile-pattern (compile-language 'pict-stuff-not-used '() '()) pat #t)
|
||||
exp)
|
||||
ans))
|
||||
|
||||
(define xab-lang #f)
|
||||
;; test-xab : sexp[pattern] sexp[term] answer -> void
|
||||
;; returns #t if pat matching exp with a simple language produces ans.
|
||||
(define (test-xab pat exp ans)
|
||||
(unless xab-lang
|
||||
(let ([nts
|
||||
(list (make-nt 'exp
|
||||
(list (make-rhs '(+ exp exp) '())
|
||||
(make-rhs 'number '())))
|
||||
(make-nt 'ctxt
|
||||
(list (make-rhs '(+ ctxt exp) '())
|
||||
(make-rhs '(+ exp ctxt) '())
|
||||
(make-rhs 'hole '())))
|
||||
|
||||
(make-nt 'ec-multi
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs '(in-named-hole xx ec-one ec-multi) '())))
|
||||
(make-nt 'ec-one
|
||||
(list (make-rhs '(+ (hole xx) exp) '())
|
||||
(make-rhs '(+ exp (hole xx)) '())))
|
||||
|
||||
(make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any)) '())))
|
||||
|
||||
(make-nt 'forever-list (list (make-rhs '(forever-list forever-list ...) '())
|
||||
(make-rhs 'x '())))
|
||||
|
||||
(make-nt 'lsts
|
||||
(list (make-rhs '() '())
|
||||
(make-rhs '(x) '())
|
||||
(make-rhs 'x '())
|
||||
(make-rhs '#f '())))
|
||||
(make-nt 'split-out
|
||||
(list (make-rhs 'split-out2 '())))
|
||||
(make-nt 'split-out2
|
||||
(list (make-rhs 'number '())))
|
||||
|
||||
(make-nt 'simple (list (make-rhs 'simple-rhs '())))
|
||||
|
||||
(make-nt 'nesting-names
|
||||
(list (make-rhs '(a (name x nesting-names)) '())
|
||||
(make-rhs 'b '())))
|
||||
(make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned '())))
|
||||
|
||||
(make-nt 'underscore (list (make-rhs 'exp_1 '())))
|
||||
)])
|
||||
(set! xab-lang
|
||||
(compile-language 'pict-stuff-not-used
|
||||
nts
|
||||
(map (λ (x) (list (nt-name x))) nts)))))
|
||||
(run-match-test
|
||||
`(match-pattern (compile-pattern xab-lang ',pat #t) ',exp)
|
||||
(match-pattern (compile-pattern xab-lang pat #t) exp)
|
||||
ans))
|
||||
|
||||
(define ab-lang #f)
|
||||
;; test-xab : sexp[pattern] sexp[term] answer -> void
|
||||
;; returns #t if pat matching exp with a simple language produces ans.
|
||||
(define (test-ab pat exp ans)
|
||||
(unless ab-lang
|
||||
(set! ab-lang
|
||||
(compile-language
|
||||
'pict-stuff-not-used
|
||||
(list (make-nt 'aa
|
||||
(list (make-rhs 'a '())))
|
||||
(make-nt 'bb
|
||||
(list (make-rhs 'b '()))))
|
||||
'((aa) (bb)))))
|
||||
(run-match-test
|
||||
`(match-pattern (compile-pattern ab-lang ',pat #t) ',exp)
|
||||
(match-pattern (compile-pattern ab-lang pat #t) exp)
|
||||
ans))
|
||||
|
||||
;; test-ellipses : sexp sexp -> void
|
||||
(define (test-ellipses pat expected)
|
||||
(run-test
|
||||
`(rewrite-ellipses test-suite:non-underscore-binder? ',pat (lambda (x) (values x #f)))
|
||||
(let-values ([(compiled-pattern has-hole?) (rewrite-ellipses test-suite:non-underscore-binder? pat (lambda (x) (values x #f)))])
|
||||
(cons compiled-pattern has-hole?))
|
||||
(cons expected #f)))
|
||||
|
||||
(define (test-suite:non-underscore-binder? x)
|
||||
(memq x '(number any variable string)))
|
||||
|
||||
;; run-test/cmp : sexp any any (any any -> boolean)
|
||||
;; compares ans with expected. If failure,
|
||||
;; prints info about the test and increments failures
|
||||
(define failures 0)
|
||||
(define test-count 0)
|
||||
(define (run-test/cmp symbolic ans expected cmp?)
|
||||
(set! test-count (+ test-count 1))
|
||||
(cond
|
||||
[(cmp? ans expected)
|
||||
'(printf "passed: ~s\n" symbolic)]
|
||||
[else
|
||||
(set! failures (+ failures 1))
|
||||
(fprintf (current-error-port)
|
||||
" test: ~s\nexpected: ~e\n got: ~e\n"
|
||||
symbolic expected ans)]))
|
||||
|
||||
(define (run-test symbolic ans expected) (run-test/cmp symbolic ans expected equal/bindings?))
|
||||
|
||||
;; run-match-test : sexp got expected
|
||||
;; expects both ans and expected to be lists or both to be #f and
|
||||
;; compares them using a set-like equality if they are lists
|
||||
(define (run-match-test symbolic ans expected)
|
||||
(run-test/cmp
|
||||
symbolic ans expected
|
||||
(λ (xs ys)
|
||||
(cond
|
||||
[(and (not xs) (not ys)) #t]
|
||||
[(and (list? xs)
|
||||
(list? ys))
|
||||
(and (andmap (λ (x) (memf (λ (y) (equal/bindings? x y)) ys)) xs)
|
||||
(andmap (λ (y) (memf (λ (x) (equal/bindings? x y)) xs)) ys)
|
||||
(= (length xs) (length ys)))]
|
||||
[else #f]))))
|
||||
|
||||
(define (build-context c)
|
||||
(let loop ([c c])
|
||||
(cond
|
||||
[(eq? c hole) hole]
|
||||
[(pair? c) (build-cons-context (loop (car c)) (loop (cdr c)))]
|
||||
[(or (null? c)
|
||||
(number? c)
|
||||
(symbol? c))
|
||||
(build-flat-context c)]
|
||||
[else (error 'build-context "unknown ~s" c)])))
|
||||
|
||||
(test))
|
||||
1647
collects/redex/private/matcher.ss
Normal file
1647
collects/redex/private/matcher.ss
Normal file
File diff suppressed because it is too large
Load Diff
58
collects/redex/private/pict-test.ss
Normal file
58
collects/redex/private/pict-test.ss
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
(module pict-test mzscheme
|
||||
;; these tests just make sure that errors don't
|
||||
;; happen. These tests are really only last resorts
|
||||
;; for testing functions that aren't easily extraced
|
||||
;; from the pict.ss library
|
||||
|
||||
(require "../reduction-semantics.ss"
|
||||
"../pict.ss")
|
||||
|
||||
(require (lib "mrpict.ss" "texpict")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss"))
|
||||
(dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1)))
|
||||
|
||||
(define-language empty-language)
|
||||
|
||||
(define-language var-ab
|
||||
[var (a
|
||||
b)])
|
||||
(language->pict var-ab #f)
|
||||
|
||||
(define-language var-not-ab
|
||||
[var (variable-except x
|
||||
y)])
|
||||
(language->pict var-not-ab #f)
|
||||
|
||||
(let ()
|
||||
(define-metafunction zero empty-language [any_in 0])
|
||||
(metafunction->pict zero))
|
||||
|
||||
(let ()
|
||||
(define-multi-args-metafunction zero empty-language [(any_in any_out) 0])
|
||||
(metafunction->pict zero))
|
||||
|
||||
(reduction-relation->pict
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> number_const
|
||||
,(term
|
||||
(+ number_const 0)))))
|
||||
|
||||
(reduction-relation->pict
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> a b
|
||||
(fresh x)
|
||||
(fresh y))))
|
||||
|
||||
|
||||
(define-language x1-9
|
||||
(x 1 2 3 4 5 6 7 8 9))
|
||||
|
||||
(define-extended-language x0-10 x1-9
|
||||
(x 0 .... 10))
|
||||
|
||||
(language->pict x0-10 #f)
|
||||
|
||||
(printf "pict-test.ss passed\n"))
|
||||
777
collects/redex/private/pict.ss
Normal file
777
collects/redex/private/pict.ss
Normal file
|
|
@ -0,0 +1,777 @@
|
|||
#lang scheme/base
|
||||
(require (lib "mrpict.ss" "texpict")
|
||||
(lib "utils.ss" "texpict")
|
||||
scheme/gui/base
|
||||
scheme/class
|
||||
"reduction-semantics.ss"
|
||||
"struct.ss"
|
||||
"loc-wrapper.ss"
|
||||
"matcher.ss"
|
||||
"arrow.ss"
|
||||
"core-layout.ss")
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(provide language->pict
|
||||
language->ps
|
||||
reduction-relation->pict
|
||||
reduction-relation->ps
|
||||
metafunction->pict
|
||||
metafunction->ps
|
||||
|
||||
basic-text
|
||||
|
||||
default-style
|
||||
label-style
|
||||
literal-style
|
||||
metafunction-style
|
||||
|
||||
label-font-size
|
||||
default-font-size
|
||||
metafunction-font-size
|
||||
reduction-relation-rule-separation
|
||||
|
||||
linebreaks
|
||||
|
||||
just-before
|
||||
just-after
|
||||
|
||||
rule-pict-style
|
||||
arrow-space
|
||||
label-space
|
||||
metafunction-pict-style
|
||||
compact-vertical-min-width
|
||||
extend-language-show-union
|
||||
set-arrow-pict!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; reduction to pict
|
||||
;;
|
||||
|
||||
(define reduction-relation->pict
|
||||
(λ (rr [rules #f])
|
||||
((rule-pict-style->proc)
|
||||
(map (rr-lws->trees (language-nts (reduction-relation-lang rr)))
|
||||
(if rules
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (lambda (rp)
|
||||
(hash-set! ht (rule-pict-label rp) rp))
|
||||
(reduction-relation-lws rr))
|
||||
(map (lambda (label)
|
||||
(hash-ref ht label
|
||||
(lambda ()
|
||||
(error 'reduction-relation->pict
|
||||
"no rule found for label: ~e"
|
||||
label))))
|
||||
rules))
|
||||
(reduction-relation-lws rr))))))
|
||||
|
||||
(define reduction-relation->ps
|
||||
(λ (rr filename [rules #f])
|
||||
(save-as-ps (λ () (reduction-relation->pict rr rules))
|
||||
filename)))
|
||||
|
||||
(define ((rr-lws->trees nts) rp)
|
||||
(let ([tp (λ (x) (lw->pict nts x))])
|
||||
(make-rule-pict (rule-pict-arrow rp)
|
||||
(tp (rule-pict-lhs rp))
|
||||
(tp (rule-pict-rhs rp))
|
||||
(rule-pict-label rp)
|
||||
(map tp (rule-pict-side-conditions rp))
|
||||
(map tp (rule-pict-fresh-vars rp))
|
||||
(map (lambda (v)
|
||||
(cons (tp (car v)) (tp (cdr v))))
|
||||
(rule-pict-pattern-binds rp)))))
|
||||
|
||||
(define current-label-extra-space (make-parameter 0))
|
||||
(define reduction-relation-rule-separation (make-parameter 4))
|
||||
|
||||
(define (rule-picts->pict/horizontal rps)
|
||||
(let* ([sep 2]
|
||||
[max-rhs (apply max
|
||||
0
|
||||
(map pict-width
|
||||
(map rule-pict-rhs rps)))]
|
||||
[max-w (apply max
|
||||
0
|
||||
(map (lambda (rp)
|
||||
(+ sep sep
|
||||
(pict-width (rule-pict-lhs rp))
|
||||
(pict-width (arrow->pict (rule-pict-arrow rp)))
|
||||
(pict-width (rule-pict-rhs rp))))
|
||||
rps))])
|
||||
(table 4
|
||||
(apply
|
||||
append
|
||||
(map (lambda (rp)
|
||||
(let ([arrow (hbl-append (blank (arrow-space) 0)
|
||||
(arrow->pict (rule-pict-arrow rp))
|
||||
(blank (arrow-space) 0))]
|
||||
[lhs (rule-pict-lhs rp)]
|
||||
[rhs (rule-pict-rhs rp)]
|
||||
[spc (basic-text " " (default-style))]
|
||||
[label (hbl-append (blank (label-space) 0) (rp->pict-label rp))]
|
||||
[sep (blank 4)])
|
||||
(list lhs arrow rhs label
|
||||
(blank) (blank)
|
||||
(let ([sc (rp->side-condition-pict rp max-w)])
|
||||
(inset sc (min 0 (- max-rhs (pict-width sc))) 0 0 0))
|
||||
(blank)
|
||||
sep (blank) (blank) (blank))))
|
||||
rps))
|
||||
(list* rtl-superimpose ctl-superimpose ltl-superimpose)
|
||||
(list* rtl-superimpose ctl-superimpose ltl-superimpose)
|
||||
(list* sep sep (+ sep (current-label-extra-space))) 2)))
|
||||
|
||||
(define arrow-space (make-parameter 0))
|
||||
(define label-space (make-parameter 0))
|
||||
|
||||
(define ((make-vertical-style side-condition-combiner) rps)
|
||||
(let* ([mk-top-line-spacer
|
||||
(λ (rp)
|
||||
(hbl-append (rule-pict-lhs rp)
|
||||
(basic-text " " (default-style))
|
||||
(arrow->pict (rule-pict-arrow rp))
|
||||
(basic-text " " (default-style))
|
||||
(rp->pict-label rp)))]
|
||||
[mk-bot-line-spacer
|
||||
(λ (rp)
|
||||
(rt-superimpose
|
||||
(rule-pict-rhs rp)
|
||||
(rp->side-condition-pict rp +inf.0)))]
|
||||
[multi-line-spacer
|
||||
(ghost
|
||||
(launder
|
||||
(ctl-superimpose
|
||||
(apply ctl-superimpose (map mk-top-line-spacer rps))
|
||||
(apply ctl-superimpose (map mk-bot-line-spacer rps)))))]
|
||||
[spacer (dc void
|
||||
(pict-width multi-line-spacer)
|
||||
(pict-descent multi-line-spacer) ;; probably could be zero ...
|
||||
0
|
||||
(pict-descent multi-line-spacer))])
|
||||
(apply
|
||||
vl-append
|
||||
(add-between
|
||||
(blank 0 (reduction-relation-rule-separation))
|
||||
(map (λ (rp)
|
||||
(side-condition-combiner
|
||||
(vl-append
|
||||
(ltl-superimpose
|
||||
(htl-append (rule-pict-lhs rp)
|
||||
(basic-text " " (default-style))
|
||||
(arrow->pict (rule-pict-arrow rp)))
|
||||
(rtl-superimpose
|
||||
spacer
|
||||
(rp->pict-label rp)))
|
||||
(rule-pict-rhs rp))
|
||||
(rp->side-condition-pict rp +inf.0)))
|
||||
rps)))))
|
||||
|
||||
(define compact-vertical-min-width (make-parameter 0))
|
||||
|
||||
(define rule-picts->pict/vertical
|
||||
(make-vertical-style vr-append))
|
||||
|
||||
(define rule-picts->pict/vertical-overlapping-side-conditions
|
||||
(make-vertical-style rbl-superimpose))
|
||||
|
||||
(define (rule-picts->pict/compact-vertical rps)
|
||||
(let ([max-w (apply max
|
||||
(compact-vertical-min-width)
|
||||
(map pict-width
|
||||
(append
|
||||
(map rule-pict-lhs rps)
|
||||
(map rule-pict-rhs rps))))])
|
||||
(table 3
|
||||
(apply
|
||||
append
|
||||
(map (lambda (rp)
|
||||
(let ([arrow (hbl-append (arrow->pict (rule-pict-arrow rp)) (blank (arrow-space) 0))]
|
||||
[lhs (rule-pict-lhs rp)]
|
||||
[rhs (rule-pict-rhs rp)]
|
||||
[spc (basic-text " " (default-style))]
|
||||
[label (hbl-append (blank (label-space) 0) (rp->pict-label rp))]
|
||||
[sep (blank (compact-vertical-min-width)
|
||||
(reduction-relation-rule-separation))])
|
||||
(if ((apply + (map pict-width (list lhs spc arrow spc rhs)))
|
||||
. < .
|
||||
max-w)
|
||||
(list
|
||||
(blank) (hbl-append lhs spc arrow spc rhs) label
|
||||
(blank) (rp->side-condition-pict rp max-w) (blank)
|
||||
(blank) sep (blank))
|
||||
(list (blank) lhs label
|
||||
arrow rhs (blank)
|
||||
(blank) (rp->side-condition-pict rp max-w) (blank)
|
||||
(blank) sep (blank)))))
|
||||
rps))
|
||||
ltl-superimpose ltl-superimpose
|
||||
(list* 2 (+ 2 (current-label-extra-space))) 2)))
|
||||
|
||||
(define (side-condition-pict fresh-vars side-conditions pattern-binds max-w)
|
||||
(let* ([frsh
|
||||
(if (null? fresh-vars)
|
||||
null
|
||||
(list
|
||||
(hbl-append
|
||||
(apply
|
||||
hbl-append
|
||||
(add-between
|
||||
(basic-text ", " (default-style))
|
||||
fresh-vars))
|
||||
(basic-text " fresh" (default-style)))))]
|
||||
[binds (map (lambda (b)
|
||||
(htl-append
|
||||
(car b)
|
||||
(make-=)
|
||||
(cdr b)))
|
||||
pattern-binds)]
|
||||
[lst (add-between
|
||||
'comma
|
||||
(append
|
||||
binds
|
||||
side-conditions
|
||||
frsh))])
|
||||
(if (null? lst)
|
||||
(blank)
|
||||
(let ([where (basic-text " where " (default-style))])
|
||||
(let ([max-w (- max-w (pict-width where))])
|
||||
(htl-append where
|
||||
(let loop ([p (car lst)][lst (cdr lst)])
|
||||
(cond
|
||||
[(null? lst) p]
|
||||
[(eq? (car lst) 'comma)
|
||||
(loop (htl-append p (basic-text ", " (default-style)))
|
||||
(cdr lst))]
|
||||
[((+ (pict-width p) (pict-width (car lst))) . > . max-w)
|
||||
(vl-append p
|
||||
(loop (car lst) (cdr lst)))]
|
||||
[else (loop (htl-append p (car lst)) (cdr lst))]))))))))
|
||||
|
||||
(define (rp->side-condition-pict rp max-w)
|
||||
(side-condition-pict (rule-pict-fresh-vars rp)
|
||||
(rule-pict-side-conditions rp)
|
||||
(rule-pict-pattern-binds rp)
|
||||
max-w))
|
||||
|
||||
(define (rp->pict-label rp)
|
||||
(if (rule-pict-label rp)
|
||||
(let ([m (regexp-match #rx"^([^_]*)(?:_([^_]*)|)$"
|
||||
(format "~a" (rule-pict-label rp)))])
|
||||
(hbl-append
|
||||
((current-text) " [" (label-style) (label-font-size))
|
||||
((current-text) (cadr m) (label-style) (label-font-size))
|
||||
(if (caddr m)
|
||||
((current-text) (caddr m) `(subscript . ,(label-style)) (label-font-size))
|
||||
(blank))
|
||||
((current-text) "]" (label-style) (label-font-size))))
|
||||
(blank)))
|
||||
|
||||
(define (add-between i l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[else
|
||||
(cons (car l)
|
||||
(apply append
|
||||
(map (λ (x) (list i x)) (cdr l))))]))
|
||||
|
||||
(define (make-horiz-space picts) (blank (pict-width (apply cc-superimpose picts)) 0))
|
||||
|
||||
(define rule-pict-style (make-parameter 'vertical))
|
||||
(define (rule-pict-style->proc)
|
||||
(case (rule-pict-style)
|
||||
[(vertical) rule-picts->pict/vertical]
|
||||
[(compact-vertical) rule-picts->pict/compact-vertical]
|
||||
[(vertical-overlapping-side-conditions)
|
||||
rule-picts->pict/vertical-overlapping-side-conditions]
|
||||
[else rule-picts->pict/horizontal]))
|
||||
|
||||
(define (mk-arrow-pict sz style)
|
||||
(let ([cache (make-hash)])
|
||||
(lambda ()
|
||||
(let ([s (default-font-size)])
|
||||
((hash-ref cache s
|
||||
(lambda ()
|
||||
(let ([f (make-arrow-pict sz style 'roman s)])
|
||||
(hash-set! cache s f)
|
||||
f))))))))
|
||||
|
||||
(define long-arrow-pict (mk-arrow-pict "xxx" 'straight))
|
||||
(define short-arrow-pict (mk-arrow-pict "m" 'straight))
|
||||
(define curvy-arrow-pict (mk-arrow-pict "xxx" 'curvy))
|
||||
(define short-curvy-arrow-pict (mk-arrow-pict "m" 'curvy))
|
||||
(define double-arrow-pict (mk-arrow-pict "xxx" 'straight-double))
|
||||
(define short-double-arrow-pict (mk-arrow-pict "m" 'straight-double))
|
||||
|
||||
(define user-arrow-table (make-hasheq))
|
||||
(define (set-arrow-pict! arr thunk)
|
||||
(hash-set! user-arrow-table arr thunk))
|
||||
|
||||
(define (arrow->pict arr)
|
||||
(let ([ut (hash-ref user-arrow-table arr #f)])
|
||||
(if ut
|
||||
(ut)
|
||||
(case arr
|
||||
[(--> -+>) (long-arrow-pict)]
|
||||
[(==>) (double-arrow-pict)]
|
||||
[(->) (short-arrow-pict)]
|
||||
[(=>) (short-double-arrow-pict)]
|
||||
[(..>) (basic-text "\u21E2" (default-style))]
|
||||
[(>->) (basic-text "\u21a3" (default-style))]
|
||||
[(~~>) (curvy-arrow-pict)]
|
||||
[(~>) (short-curvy-arrow-pict)]
|
||||
[(:->) (basic-text "\u21a6" (default-style))]
|
||||
[(c->) (basic-text "\u21aa" (default-style))]
|
||||
[(-->>) (basic-text "\u21a0" (default-style))]
|
||||
[(>--) (basic-text "\u291a" (default-style))]
|
||||
[(--<) (basic-text "\u2919" (default-style))]
|
||||
[(>>--) (basic-text "\u291c" (default-style))]
|
||||
[(--<<) (basic-text "\u291b" (default-style))]
|
||||
[else (error 'arrow->pict "unknown arrow ~s" arr)]))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; language to pict
|
||||
;;
|
||||
|
||||
;; type flattened-language-pict-info =
|
||||
;; (listof (cons (listof symbol[nt]) (listof loc-wrapper[rhs])))
|
||||
;; type language-pict-info =
|
||||
;; (union (vector flattened-language-pict-info language-pict-info)
|
||||
;; flattened-language-pict-info)
|
||||
|
||||
(define (language->ps lang filename [non-terminals #f] #:pict-wrap [pict-wrap (lambda (p) p)])
|
||||
(when non-terminals
|
||||
(check-non-terminals 'language->ps non-terminals lang))
|
||||
(save-as-ps (λ () (pict-wrap (language->pict lang non-terminals)))
|
||||
filename))
|
||||
|
||||
(define (language->pict lang [non-terminals #f])
|
||||
(when non-terminals
|
||||
(check-non-terminals 'language->pict non-terminals lang))
|
||||
(let* ([all-non-terminals (hash-map (compiled-lang-ht lang) (λ (x y) x))]
|
||||
[non-terminals (or non-terminals all-non-terminals)])
|
||||
(make-grammar-pict (compiled-lang-pict-builder lang)
|
||||
non-terminals
|
||||
all-non-terminals)))
|
||||
|
||||
(define (check-non-terminals what nts lang)
|
||||
(let ([langs-nts (language-nts lang)])
|
||||
(for-each
|
||||
(λ (nt)
|
||||
(unless (memq nt langs-nts)
|
||||
(error what
|
||||
"the non-terminal ~s is not one of the language's nonterminals (~a)"
|
||||
nt
|
||||
(if (null? langs-nts)
|
||||
"it has no non-terminals"
|
||||
(apply
|
||||
string-append
|
||||
"which are: "
|
||||
(format "~a" (car langs-nts))
|
||||
(map (λ (x) (format " ~a" x)) (cdr langs-nts)))))))
|
||||
nts)))
|
||||
|
||||
;; lang-pict-builder : (-> pict) string -> void
|
||||
(define (save-as-ps mk-pict filename)
|
||||
(let ([ps-dc (make-ps-dc filename)])
|
||||
(parameterize ([dc-for-text-size ps-dc])
|
||||
(send ps-dc start-doc "x")
|
||||
(send ps-dc start-page)
|
||||
(draw-pict (mk-pict) ps-dc 0 0)
|
||||
(send ps-dc end-page)
|
||||
(send ps-dc end-doc))))
|
||||
|
||||
(define (make-ps-dc filename)
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file filename)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(make-object post-script-dc% #f #f))))
|
||||
|
||||
;; raw-info : language-pict-info
|
||||
;; nts : (listof symbol) -- the nts that the user expects to see
|
||||
(define (make-grammar-pict raw-info nts all-nts)
|
||||
(let* ([info (remove-unwanted-nts nts (flatten-grammar-info raw-info all-nts))]
|
||||
[term-space
|
||||
(launder
|
||||
(ghost
|
||||
(apply cc-superimpose (map (λ (x) (sequence-of-non-terminals (car x)))
|
||||
info))))])
|
||||
(apply vl-append
|
||||
(map (λ (line)
|
||||
(htl-append
|
||||
(rc-superimpose term-space (sequence-of-non-terminals (car line)))
|
||||
(lw->pict
|
||||
all-nts
|
||||
(find-enclosing-loc-wrapper (add-bars-and-::= (cdr line))))))
|
||||
info))))
|
||||
|
||||
(define (sequence-of-non-terminals nts)
|
||||
(let loop ([nts (cdr nts)]
|
||||
[pict (non-terminal (format "~a" (car nts)))])
|
||||
(cond
|
||||
[(null? nts) pict]
|
||||
[else
|
||||
(loop (cdr nts)
|
||||
(hbl-append pict
|
||||
(non-terminal (format ", ~a" (car nts)))))])))
|
||||
|
||||
|
||||
(define extend-language-show-union (make-parameter #f))
|
||||
|
||||
;; remove-unwanted-nts : (listof symbol) flattened-language-pict-info -> flattened-language-pict-info
|
||||
(define (remove-unwanted-nts nts info)
|
||||
(filter (λ (x) (not (null? (car x))))
|
||||
(map
|
||||
(λ (x) (cons (filter (λ (x) (member x nts)) (car x))
|
||||
(cdr x)))
|
||||
info)))
|
||||
|
||||
|
||||
;; flatten-grammar-info : language-pict-info (listof symbol) -> flattened-language-pict-info
|
||||
(define (flatten-grammar-info info all-nts)
|
||||
(let ([union? (extend-language-show-union)])
|
||||
(let loop ([info info])
|
||||
(cond
|
||||
[(vector? info)
|
||||
(let ([orig (loop (vector-ref info 0))]
|
||||
[extensions (vector-ref info 1)])
|
||||
(if union?
|
||||
(map (λ (orig-line)
|
||||
(let* ([nt (car orig-line)]
|
||||
[extension (assoc nt extensions)])
|
||||
(if extension
|
||||
(let ([rhss (cdr extension)])
|
||||
(cons nt
|
||||
(map (λ (x)
|
||||
(if (and (lw? x) (eq? '.... (lw-e x)))
|
||||
(struct-copy lw
|
||||
x
|
||||
[e
|
||||
(lw->pict all-nts
|
||||
(find-enclosing-loc-wrapper
|
||||
(add-bars (cdr orig-line))))])
|
||||
x))
|
||||
(cdr extension))))
|
||||
orig-line)))
|
||||
orig)
|
||||
extensions))]
|
||||
[else info]))))
|
||||
|
||||
(define (make-::=) (basic-text " ::= " (default-style)))
|
||||
(define (make-bar)
|
||||
(basic-text " | " (default-style))
|
||||
#;
|
||||
(let ([p (basic-text " | " (default-style))])
|
||||
(dc
|
||||
(λ (dc dx dy)
|
||||
(cond
|
||||
[(is-a? dc post-script-dc%)
|
||||
(let ([old-pen (send dc get-pen)])
|
||||
(send dc set-pen "black" .6 'solid)
|
||||
(send dc draw-line
|
||||
(+ dx (/ (pict-width p) 2)) dy
|
||||
(+ dx (/ (pict-width p) 2)) (+ dy (pict-height p)))
|
||||
(send dc set-pen old-pen))]
|
||||
[else
|
||||
(send dc draw-text " | " dx dy)]))
|
||||
(pict-width p)
|
||||
(pict-height p)
|
||||
(pict-ascent p)
|
||||
(pict-descent p))))
|
||||
|
||||
(define (add-bars-and-::= lst)
|
||||
(cond
|
||||
[(null? lst) null]
|
||||
[else
|
||||
(cons
|
||||
(let ([fst (car lst)])
|
||||
(build-lw
|
||||
(rc-superimpose (ghost (make-bar)) (make-::=))
|
||||
(lw-line fst)
|
||||
(lw-line-span fst)
|
||||
(lw-column fst)
|
||||
0))
|
||||
(let loop ([fst (car lst)]
|
||||
[rst (cdr lst)])
|
||||
(cond
|
||||
[(null? rst) (list fst)]
|
||||
[else
|
||||
(let* ([snd (car rst)]
|
||||
[bar
|
||||
(cond
|
||||
[(= (lw-line snd)
|
||||
(lw-line fst))
|
||||
(let* ([line (lw-line snd)]
|
||||
[line-span (lw-line-span snd)]
|
||||
[column (+ (lw-column fst)
|
||||
(lw-column-span fst))]
|
||||
[column-span
|
||||
(- (lw-column snd)
|
||||
(+ (lw-column fst)
|
||||
(lw-column-span fst)))])
|
||||
(build-lw (make-bar) line line-span column column-span))]
|
||||
[else
|
||||
(build-lw
|
||||
(rc-superimpose (make-bar) (ghost (make-::=)))
|
||||
(lw-line snd)
|
||||
(lw-line-span snd)
|
||||
(lw-column snd)
|
||||
0)])])
|
||||
(list* fst
|
||||
bar
|
||||
(loop snd (cdr rst))))])))]))
|
||||
|
||||
(define (add-bars lst)
|
||||
(let loop ([fst (car lst)]
|
||||
[rst (cdr lst)])
|
||||
(cond
|
||||
[(null? rst) (list fst)]
|
||||
[else
|
||||
(let* ([snd (car rst)]
|
||||
[bar
|
||||
(cond
|
||||
[(= (lw-line snd)
|
||||
(lw-line fst))
|
||||
(let* ([line (lw-line snd)]
|
||||
[line-span (lw-line-span snd)]
|
||||
[column (+ (lw-column fst)
|
||||
(lw-column-span fst))]
|
||||
[column-span
|
||||
(- (lw-column snd)
|
||||
(+ (lw-column fst)
|
||||
(lw-column-span fst)))])
|
||||
(build-lw (make-bar) line line-span column column-span))]
|
||||
[else
|
||||
(build-lw
|
||||
(make-bar)
|
||||
(lw-line snd)
|
||||
(lw-line-span snd)
|
||||
(lw-column snd)
|
||||
0)])])
|
||||
(list* fst
|
||||
bar
|
||||
(loop snd (cdr rst))))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; metafunction to pict
|
||||
;;
|
||||
|
||||
(define (make-=) (basic-text " = " (default-style)))
|
||||
|
||||
(define-syntax (metafunction->pict stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(identifier? #'name)
|
||||
#'(metafunction->pict/proc (metafunction name))]))
|
||||
|
||||
(define-syntax (metafunction->ps stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name file)
|
||||
(identifier? #'name)
|
||||
#'(metafunction->ps/proc (metafunction name) file)]))
|
||||
|
||||
(define linebreaks (make-parameter #f))
|
||||
|
||||
(define metafunction-pict-style (make-parameter 'left-right))
|
||||
|
||||
(define metafunction->pict/proc
|
||||
(lambda (mf)
|
||||
(let ([current-linebreaks (linebreaks)]
|
||||
[all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))]
|
||||
[sep 2])
|
||||
(let* ([wrapper->pict (lambda (lw) (lw->pict all-nts lw))]
|
||||
[eqns (metafunc-proc-pict-info (metafunction-proc mf))]
|
||||
[lhss (map (lambda (eqn)
|
||||
(wrapper->pict
|
||||
(metafunction-call (metafunc-proc-name (metafunction-proc mf))
|
||||
(car eqn)
|
||||
(metafunc-proc-multi-arg? (metafunction-proc mf)))))
|
||||
eqns)]
|
||||
[scs (map (lambda (eqn)
|
||||
(if (and (null? (cadr eqn))
|
||||
(null? (caddr eqn)))
|
||||
#f
|
||||
(side-condition-pict null
|
||||
(map wrapper->pict (cadr eqn))
|
||||
(map (lambda (p)
|
||||
(cons (wrapper->pict (car p)) (wrapper->pict (cdr p))))
|
||||
(caddr eqn))
|
||||
+inf.0)))
|
||||
eqns)]
|
||||
[rhss (map (lambda (eqn) (wrapper->pict (cadddr eqn))) eqns)]
|
||||
[linebreak-list (or current-linebreaks
|
||||
(map (lambda (x) #f) eqns))]
|
||||
[=-pict (make-=)]
|
||||
[max-lhs-w (apply max (map pict-width lhss))]
|
||||
[max-line-w (apply
|
||||
max
|
||||
(map (lambda (lhs sc rhs linebreak?)
|
||||
(max
|
||||
(if sc (pict-width sc) 0)
|
||||
(if linebreak?
|
||||
(max (pict-width lhs)
|
||||
(+ (pict-width rhs) (pict-width =-pict)))
|
||||
(+ (pict-width lhs) (pict-width rhs) (pict-width =-pict)
|
||||
(* 2 sep)))))
|
||||
lhss scs rhss linebreak-list))])
|
||||
(case (metafunction-pict-style)
|
||||
[(left-right)
|
||||
(table 3
|
||||
(apply append
|
||||
(map (lambda (lhs sc rhs linebreak?)
|
||||
(append
|
||||
(if linebreak?
|
||||
(list lhs (blank) (blank))
|
||||
(list lhs =-pict rhs))
|
||||
(if linebreak?
|
||||
(let ([p rhs])
|
||||
(list (hbl-append sep
|
||||
=-pict
|
||||
(inset p 0 0 (- 5 (pict-width p)) 0))
|
||||
(blank)
|
||||
;; n case this line sets the max width, add suitable space in the right:
|
||||
(blank (max 0 (- (pict-width p) max-lhs-w sep))
|
||||
0)))
|
||||
null)
|
||||
(if (not sc)
|
||||
null
|
||||
(list (inset sc 0 0 (- 5 (pict-width sc)) 0)
|
||||
(blank)
|
||||
;; In case sc set the max width...
|
||||
(blank (max 0 (- (pict-width sc) max-lhs-w (pict-width =-pict) (* 2 sep)))
|
||||
0)))))
|
||||
lhss
|
||||
scs
|
||||
rhss
|
||||
linebreak-list))
|
||||
ltl-superimpose ltl-superimpose
|
||||
sep sep)]
|
||||
[(up-down)
|
||||
(apply vl-append
|
||||
sep
|
||||
(apply append
|
||||
(map (lambda (lhs sc rhs)
|
||||
(cons
|
||||
(vl-append (hbl-append lhs =-pict) rhs)
|
||||
(if (not sc)
|
||||
null
|
||||
(list (inset sc 0 0 (- 5 (pict-width sc)) 0)))))
|
||||
lhss
|
||||
scs
|
||||
rhss)))])))))
|
||||
|
||||
(define (metafunction-call name an-lw flattened?)
|
||||
(if flattened?
|
||||
(struct-copy lw an-lw
|
||||
[e
|
||||
(list*
|
||||
;; the first loc wrapper is just there to make the
|
||||
;; shape of this line be one that the apply-rewrites
|
||||
;; function (in core-layout.ss) recognizes as a metafunction
|
||||
(make-lw ""
|
||||
(lw-line an-lw)
|
||||
0
|
||||
(lw-column an-lw)
|
||||
0
|
||||
#f
|
||||
#f)
|
||||
(make-lw name
|
||||
(lw-line an-lw)
|
||||
0
|
||||
(lw-column an-lw)
|
||||
0
|
||||
#f
|
||||
'multi)
|
||||
(cdr (lw-e an-lw)))])
|
||||
|
||||
(build-lw
|
||||
(list
|
||||
(build-lw "("
|
||||
(lw-line an-lw)
|
||||
0
|
||||
(lw-column an-lw)
|
||||
0)
|
||||
(make-lw name
|
||||
(lw-line an-lw)
|
||||
0
|
||||
(lw-column an-lw)
|
||||
0
|
||||
#f
|
||||
'single)
|
||||
an-lw
|
||||
(build-lw ")"
|
||||
(+ (lw-line an-lw)
|
||||
(lw-line-span an-lw))
|
||||
0
|
||||
(+ (lw-column an-lw)
|
||||
(lw-column-span an-lw))
|
||||
0))
|
||||
(lw-line an-lw)
|
||||
(lw-line-span an-lw)
|
||||
(lw-column an-lw)
|
||||
(lw-column-span an-lw))))
|
||||
|
||||
(define (add-commas-and-rewrite-parens eles)
|
||||
(let loop ([eles eles]
|
||||
[between-parens? #f]
|
||||
[comma-pending #f])
|
||||
(cond
|
||||
[(null? eles) null]
|
||||
[else
|
||||
(let ([an-lw (car eles)])
|
||||
(cond
|
||||
[(not (lw? an-lw))
|
||||
(cons an-lw (loop (cdr eles) between-parens? #f))]
|
||||
[(equal? "(" (lw-e an-lw))
|
||||
(cons (struct-copy lw
|
||||
an-lw
|
||||
[e (open-white-square-bracket)])
|
||||
(loop (cdr eles) #t #f))]
|
||||
[(equal? ")" (lw-e an-lw))
|
||||
(cons (struct-copy lw
|
||||
an-lw
|
||||
[e (close-white-square-bracket)])
|
||||
(loop (cdr eles) #f #f))]
|
||||
[(and between-parens?
|
||||
comma-pending)
|
||||
(list* (build-lw (basic-text ", " (default-style))
|
||||
(car comma-pending)
|
||||
0
|
||||
(cdr comma-pending)
|
||||
0)
|
||||
'spring
|
||||
(loop eles #t #f))]
|
||||
[else
|
||||
(cons an-lw
|
||||
(loop (cdr eles)
|
||||
between-parens?
|
||||
(if between-parens?
|
||||
(cons (+ (lw-line an-lw) (lw-line-span an-lw))
|
||||
(+ (lw-column an-lw) (lw-column-span an-lw)))
|
||||
#f)))]))])))
|
||||
|
||||
(define (replace-paren x)
|
||||
(cond
|
||||
[(not (lw? x)) x]
|
||||
[(equal? "(" (lw-e x))
|
||||
(struct-copy lw
|
||||
x
|
||||
[e (hbl-append -2
|
||||
(basic-text "[" (default-style))
|
||||
(basic-text "[" (default-style)))])]
|
||||
[(equal? ")" (lw-e x))
|
||||
(struct-copy lw
|
||||
x
|
||||
[e
|
||||
(hbl-append -2
|
||||
(basic-text "]" (default-style))
|
||||
(basic-text "]" (default-style)))])]
|
||||
[else x]))
|
||||
|
||||
(define (metafunction->ps/proc mf filename)
|
||||
(save-as-ps (λ () (metafunction->pict/proc mf))
|
||||
filename))
|
||||
31
collects/redex/private/red-sem-macro-helpers.ss
Normal file
31
collects/redex/private/red-sem-macro-helpers.ss
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
(module red-sem-macro-helpers mzscheme
|
||||
|
||||
(provide extract-names)
|
||||
|
||||
(require (lib "match.ss"))
|
||||
|
||||
(define (extract-names stx)
|
||||
(let ([dup-names
|
||||
(let loop ([sexp (syntax-object->datum stx)]
|
||||
[names null])
|
||||
(match sexp
|
||||
[`(name ,(and sym (? symbol?)) ,pat)
|
||||
(loop pat (cons sym names))]
|
||||
[`(in-hole* ,(and sym (? symbol?)) ,pat1 ,pat2)
|
||||
(loop pat1
|
||||
(loop pat2
|
||||
(cons sym names)))]
|
||||
[`(in-hole ,pat1 ,pat2)
|
||||
(loop pat1
|
||||
(loop pat2
|
||||
(cons 'hole names)))]
|
||||
[(? list?)
|
||||
(let i-loop ([sexp sexp]
|
||||
[names names])
|
||||
(cond
|
||||
[(null? sexp) names]
|
||||
[else (i-loop (cdr sexp) (loop (car sexp) names))]))]
|
||||
[else names]))]
|
||||
[ht (make-hash-table)])
|
||||
(for-each (lambda (name) (hash-table-put! ht name #f)) dup-names)
|
||||
(hash-table-map ht (lambda (x y) x)))))
|
||||
1613
collects/redex/private/reduction-semantics.ss
Normal file
1613
collects/redex/private/reduction-semantics.ss
Normal file
File diff suppressed because it is too large
Load Diff
176
collects/redex/private/rewrite-side-conditions.ss
Normal file
176
collects/redex/private/rewrite-side-conditions.ss
Normal file
|
|
@ -0,0 +1,176 @@
|
|||
(module rewrite-side-conditions mzscheme
|
||||
(require (lib "list.ss")
|
||||
"underscore-allowed.ss")
|
||||
(require-for-template mzscheme
|
||||
"term.ss"
|
||||
"matcher.ss")
|
||||
|
||||
(provide rewrite-side-conditions/check-errs
|
||||
extract-names
|
||||
make-language-id
|
||||
language-id-nts)
|
||||
|
||||
(define-values (language-id make-language-id language-id? language-id-get language-id-set) (make-struct-type 'language-id #f 2 0 #f '() #f 0))
|
||||
|
||||
(define (language-id-nts stx id) (language-id-getter stx id 1))
|
||||
(define (language-id-getter stx id n)
|
||||
(unless (identifier? stx)
|
||||
(raise-syntax-error id "expected an identifier defined by define-language" stx))
|
||||
(let ([val (syntax-local-value stx (λ () #f))])
|
||||
(unless (and (set!-transformer? val)
|
||||
(language-id? (set!-transformer-procedure val)))
|
||||
(raise-syntax-error id "expected a identifier defined by define-language" stx))
|
||||
(language-id-get (set!-transformer-procedure val) n)))
|
||||
|
||||
(define (rewrite-side-conditions/check-errs all-nts what bind-names? orig-stx)
|
||||
(define (expected-exact name n stx)
|
||||
(raise-syntax-error what (format "~a expected to have ~a arguments"
|
||||
name
|
||||
n)
|
||||
orig-stx
|
||||
stx))
|
||||
(define (expected-arguments name stx)
|
||||
(raise-syntax-error what (format "~a expected to have arguments" name) orig-stx stx))
|
||||
(let loop ([term orig-stx])
|
||||
(syntax-case term (side-condition variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross)
|
||||
[(side-condition pre-pat exp)
|
||||
(with-syntax ([pat (loop (syntax pre-pat))])
|
||||
(let-values ([(names names/ellipses) (extract-names all-nts what bind-names? (syntax pat))])
|
||||
(with-syntax ([(name ...) names]
|
||||
[(name/ellipses ...) names/ellipses])
|
||||
(syntax/loc term
|
||||
(side-condition
|
||||
pat
|
||||
,(lambda (bindings)
|
||||
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
|
||||
exp)))))))]
|
||||
[(side-condition a ...) (expected-exact 'side-condition 2 term)]
|
||||
[side-condition (expected-arguments 'side-condition term)]
|
||||
[(variable-except a ...) #`(variable-except #,@(map loop (syntax->list (syntax (a ...)))))]
|
||||
[variable-except (expected-arguments 'variable-except term)]
|
||||
[(variable-prefix a) #`(variable-prefix #,(loop (syntax a)))]
|
||||
[(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)]
|
||||
[variable-prefix (expected-arguments 'variable-prefix term)]
|
||||
[hole term]
|
||||
[(hole a) #`(hole #,(loop #'a))]
|
||||
[(hole a ...) (raise-syntax-error what "hole expected to stand alone or to have one argument")]
|
||||
[(name x y) #`(name #,(loop #'x) #,(loop #'y))]
|
||||
[(name x ...) (expected-exact 'name 2 term)]
|
||||
[name (expected-arguments 'name term)]
|
||||
[(in-hole a b) #`(in-hole #,(loop #'a) #,(loop #'b))]
|
||||
[(in-hole a ...) (expected-exact 'in-hole 2 term)]
|
||||
[in-hole (expected-arguments 'in-hole term)]
|
||||
[(in-named-hole a b c) #`(in-named-hole #,(loop #'a) #,(loop #'b) #,(loop #'c))]
|
||||
[(in-named-hole a ...) (expected-exact 'in-named-hole 3 term)]
|
||||
[in-named-hole (expected-arguments 'in-named-hole term)]
|
||||
[(hide-hole a) #`(hide-hole #,(loop #'a))]
|
||||
[(in-named-hole a ...) (expected-exact 'hide-hole 1 term)]
|
||||
[in-named-hole (expected-arguments 'hide-hole term)]
|
||||
[(cross a) #`(cross #,(loop #'a))]
|
||||
[(cross a ...) (expected-exact 'cross 1 term)]
|
||||
[cross (expected-arguments 'cross term)]
|
||||
[(terms ...)
|
||||
(map loop (syntax->list (syntax (terms ...))))]
|
||||
[else
|
||||
(when (pair? (syntax-e term))
|
||||
(let loop ([term term])
|
||||
(cond
|
||||
[(syntax? term) (loop (syntax-e term))]
|
||||
[(pair? term) (loop (cdr term))]
|
||||
[(null? term) (void)]
|
||||
[#t
|
||||
(raise-syntax-error what "dotted pairs not supported in patterns" orig-stx term)])))
|
||||
term])))
|
||||
|
||||
(define-struct id/depth (id depth))
|
||||
|
||||
;; extract-names : syntax syntax -> (values (listof syntax) (listof syntax[x | (x ...) | ((x ...) ...) | ...]))
|
||||
(define (extract-names all-nts what bind-names? orig-stx)
|
||||
(let* ([dups
|
||||
(let loop ([stx orig-stx]
|
||||
[names null]
|
||||
[depth 0])
|
||||
(syntax-case stx (name in-hole in-named-hole side-condition)
|
||||
[(name sym pat)
|
||||
(identifier? (syntax sym))
|
||||
(loop (syntax pat)
|
||||
(cons (make-id/depth (syntax sym) depth) names)
|
||||
depth)]
|
||||
[(in-named-hole hlnm sym pat1 pat2)
|
||||
(identifier? (syntax sym))
|
||||
(loop (syntax pat1)
|
||||
(loop (syntax pat2) names depth)
|
||||
depth)]
|
||||
[(in-hole pat1 pat2)
|
||||
(loop (syntax pat1)
|
||||
(loop (syntax pat2) names depth)
|
||||
depth)]
|
||||
[(side-condition pat e)
|
||||
(loop (syntax pat) names depth)]
|
||||
[(pat ...)
|
||||
(let i-loop ([pats (syntax->list (syntax (pat ...)))]
|
||||
[names names])
|
||||
(cond
|
||||
[(null? pats) names]
|
||||
[else
|
||||
(if (or (null? (cdr pats))
|
||||
(not (identifier? (cadr pats)))
|
||||
(not (or (module-identifier=? (quote-syntax ...)
|
||||
(cadr pats))
|
||||
(let ([inside (syntax-e (cadr pats))])
|
||||
(regexp-match #rx"^\\.\\.\\._" (symbol->string inside))))))
|
||||
(i-loop (cdr pats)
|
||||
(loop (car pats) names depth))
|
||||
(i-loop (cdr pats)
|
||||
(loop (car pats) names (+ depth 1))))]))]
|
||||
[x
|
||||
(and (identifier? (syntax x))
|
||||
(binds-in-right-hand-side? all-nts bind-names? (syntax x)))
|
||||
(cons (make-id/depth (syntax x) depth) names)]
|
||||
[else names]))]
|
||||
[no-dups (filter-duplicates what orig-stx dups)])
|
||||
(values (map id/depth-id no-dups)
|
||||
(map build-dots no-dups))))
|
||||
|
||||
;; build-dots : id/depth -> syntax[x | (x ...) | ((x ...) ...) | ...]
|
||||
(define (build-dots id/depth)
|
||||
(let loop ([depth (id/depth-depth id/depth)])
|
||||
(cond
|
||||
[(zero? depth) (id/depth-id id/depth)]
|
||||
[else (with-syntax ([rest (loop (- depth 1))]
|
||||
[dots (quote-syntax ...)])
|
||||
(syntax (rest dots)))])))
|
||||
|
||||
|
||||
(define (binds-in-right-hand-side? nts bind-names? x)
|
||||
(or (and bind-names? (memq (syntax-e x) nts))
|
||||
(and bind-names? (memq (syntax-e x) underscore-allowed))
|
||||
(let ([str (symbol->string (syntax-e x))])
|
||||
(and (regexp-match #rx"_" str)
|
||||
(not (regexp-match #rx"^\\.\\.\\._" str))
|
||||
(not (regexp-match #rx"_!_" str))))))
|
||||
|
||||
(define (filter-duplicates what orig-stx dups)
|
||||
(let loop ([dups dups])
|
||||
(cond
|
||||
[(null? dups) null]
|
||||
[else
|
||||
(cons
|
||||
(car dups)
|
||||
(filter (lambda (x)
|
||||
(let ([same-id? (module-identifier=? (id/depth-id x)
|
||||
(id/depth-id (car dups)))])
|
||||
(when same-id?
|
||||
(unless (equal? (id/depth-depth x)
|
||||
(id/depth-depth (car dups)))
|
||||
(raise
|
||||
(make-exn:fail:syntax
|
||||
(format "~a: found the same binder, ~s, at different depths, ~a and ~a"
|
||||
what
|
||||
(syntax-object->datum (id/depth-id x))
|
||||
(id/depth-depth x)
|
||||
(id/depth-depth (car dups)))
|
||||
(current-continuation-marks)
|
||||
(list (id/depth-id x) (id/depth-id (car dups)))))))
|
||||
(not same-id?)))
|
||||
(loop (cdr dups))))]))))
|
||||
383
collects/redex/private/rg-test.ss
Normal file
383
collects/redex/private/rg-test.ss
Normal file
|
|
@ -0,0 +1,383 @@
|
|||
#lang scheme
|
||||
|
||||
(require "test-util.ss"
|
||||
"reduction-semantics.ss"
|
||||
"matcher.ss"
|
||||
"term.ss"
|
||||
"rg.ss")
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
||||
|
||||
;; to-table : hash-table -> assoc
|
||||
;; extracts the hash-table's mapping in a deterministic way
|
||||
(define (to-table ht)
|
||||
(sort (hash-map ht cons)
|
||||
(λ (x y) (string<=? (format "~a" (car x)) (format "~a" (car y))))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(e x (e e) (λ (x) e))
|
||||
(x variable))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (1 2 2)) (x . (0)))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(e (e e)))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (inf)))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(a 1 2 3)
|
||||
(b a (a b)))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((a . (0 0 0)) (b . (1 2)))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(e (e e)
|
||||
(+ e e)
|
||||
x
|
||||
v)
|
||||
(v (λ (x) e)
|
||||
number)
|
||||
(x variable))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (2 2 1 1)) (v . (2 0)) (x . (0)))))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e number x y)
|
||||
(x variable)
|
||||
(y y))
|
||||
(test (min-prods (car (compiled-lang-lang lang)) (find-base-cases lang))
|
||||
(list (car (nt-rhs (car (compiled-lang-lang lang)))))))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a (side-condition "strin_g" #t) 1/2 #t))
|
||||
(let* ([literals (sort (lang-literals lang) string<=?)]
|
||||
[chars (sort (unique-chars literals) char<=?)])
|
||||
(test literals '("1/2" "side-condition" "strin_g"))
|
||||
(test chars '(#\- #\/ #\1 #\2 #\c #\d #\e #\g #\i #\n #\o #\r #\s #\t))))
|
||||
|
||||
(define (make-random nums)
|
||||
(let ([nums (box nums)])
|
||||
(λ (m)
|
||||
(cond [(null? (unbox nums)) (error 'make-random "out of numbers")]
|
||||
[(>= (car (unbox nums)) m) (error 'make-random "number too large")]
|
||||
[else (begin0 (car (unbox nums)) (set-box! nums (cdr (unbox nums))))]))))
|
||||
|
||||
(test (pick-from-list '(a b c) (make-random '(1))) 'b)
|
||||
|
||||
(test (pick-length (make-random '(1 1 1 0))) 3)
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a bcd cbd))
|
||||
(let* ([lits (sort (lang-literals lang) string<=?)]
|
||||
[chars (sort (unique-chars lits) char<=?)])
|
||||
(test (pick-char 0 chars (make-random '(1))) #\c)
|
||||
(test (pick-char 50 chars (make-random '(1 1))) #\c)
|
||||
(test (pick-char 50 chars (make-random '(0 65))) #\a)
|
||||
(test (pick-char 500 chars (make-random '(0 1 65))) #\a)
|
||||
(test (pick-char 500 chars (make-random '(0 0 3))) #\⇒)
|
||||
(test (pick-char 2000 chars (make-random '(0 0 1 3))) #\⇒)
|
||||
(test (pick-char 2000 chars (make-random '(0 0 0 1))) (integer->char #x4E01))
|
||||
(test (pick-char 50 chars (make-random `(0 ,(- (char->integer #\_) #x20)))) #\`)
|
||||
(test (random-string chars lits 3 0 (make-random '(0 1))) "cbd")
|
||||
(test (random-string chars lits 3 0 (make-random '(1 2 1 0))) "dcb")
|
||||
(test (pick-string chars lits 0 (make-random '(1 1 1 0 1 2 1 0))) "dcb")
|
||||
(test (pick-var chars lits null 0 (make-random '(0 0 1 1 2 1 0))) 'dcb)
|
||||
(test (pick-var chars lits '(x) 0 (make-random '(1 0))) 'x)))
|
||||
|
||||
(define (rhs-matching pat prods)
|
||||
(cond [(null? prods) (error 'rhs-matching "no rhs matching ~s" pat)]
|
||||
[(equal? (rhs-pattern (car prods)) pat) (car prods)]
|
||||
[else (rhs-matching pat (cdr prods))]))
|
||||
|
||||
(let ()
|
||||
(define-language l (a (a b) (a b c) c))
|
||||
(test (rhs-matching '(a b c) (nt-rhs (car (compiled-lang-lang l))))
|
||||
(cadr (nt-rhs (car (compiled-lang-lang l)))))
|
||||
(test (with-handlers ([exn:fail? exn-message])
|
||||
(rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l)))))
|
||||
#rx"no rhs matching"))
|
||||
|
||||
(define (select-pattern pat)
|
||||
(λ (prods . _) (rhs-matching pat prods)))
|
||||
|
||||
(define (iterator name items)
|
||||
(let ([bi (box items)])
|
||||
(λ ()
|
||||
(if (null? (unbox bi))
|
||||
(error name "empty")
|
||||
(begin0 (car (unbox bi)) (set-box! bi (cdr (unbox bi))))))))
|
||||
|
||||
(let ([iter (iterator 'test-iterator '(a b))])
|
||||
(test (iter) 'a)
|
||||
(test (iter) 'b)
|
||||
(test (with-handlers ([exn:fail? exn-message]) (iter)) #rx"empty"))
|
||||
|
||||
(define (decisions #:var [var pick-var]
|
||||
#:nt [nt pick-nt]
|
||||
#:str [str pick-string]
|
||||
#:num [num pick-from-list]
|
||||
#:seq [seq pick-length])
|
||||
(define-syntax decision
|
||||
(syntax-rules ()
|
||||
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
|
||||
(unit (import) (export decisions^)
|
||||
(define next-variable-decision (decision var))
|
||||
(define next-non-terminal-decision (decision nt))
|
||||
(define next-number-decision (decision num))
|
||||
(define next-string-decision (decision str))
|
||||
(define next-sequence-decision (decision seq))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(e (e e) x (λ (x) e) #:binds x e)
|
||||
(x (variable-except λ)))
|
||||
|
||||
;; Generate (λ (x) x)
|
||||
(test
|
||||
(generate
|
||||
lc 'e 1 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _'x))
|
||||
#:nt (list (select-pattern '(λ (x) e))
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern 'x)
|
||||
(select-pattern '(variable-except λ)))))
|
||||
'(λ (x) x))
|
||||
|
||||
;; Generate pattern that's not a non-terminal
|
||||
(test
|
||||
(generate
|
||||
lc '(x_1 x_1) 1 0
|
||||
(decisions #:var (list (λ _ 'x))))
|
||||
'(x x))
|
||||
|
||||
;; Minimum rhs is chosen with zero size
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lc 'e 0 0
|
||||
(decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods)))))))
|
||||
'(x))
|
||||
|
||||
;; Size decremented
|
||||
(let ([size 5])
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lc 'e size 0
|
||||
(decisions #:nt (list (select-pattern 'x) (λ (p b s) (k s))))))
|
||||
(sub1 size))))
|
||||
|
||||
;; Detection of binding kludge
|
||||
(let ()
|
||||
(define-language postfix
|
||||
(e (e e) x (e (x) λ) #:binds x e)
|
||||
(x (variable-except λ)))
|
||||
(test
|
||||
(with-handlers ([exn:fail? exn-message])
|
||||
(generate
|
||||
postfix 'e 2 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y))
|
||||
#:nt (list (select-pattern '(e (x) λ))
|
||||
(select-pattern 'x)
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern '(variable-except λ))))))
|
||||
#rx"kludge"))
|
||||
|
||||
;; variable-except pattern
|
||||
(let ()
|
||||
(define-language var
|
||||
(e (variable-except x y)))
|
||||
(test
|
||||
(generate
|
||||
var 'e 2 0
|
||||
(decisions #:nt (list (select-pattern '(variable-except x y)))
|
||||
#:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
|
||||
'z))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e (number number ... "foo" ... "bar" #t ...)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 2 0
|
||||
(decisions #:num (build-list 3 (λ (n) (λ (_) n)))
|
||||
#:seq (list (λ () 2) (λ () 3) (λ () 1))))
|
||||
`(0 1 2 "foo" "foo" "foo" "bar" #t)))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(e (λ (x ...) e) #:binds x e
|
||||
(e e)
|
||||
x)
|
||||
(x (variable-except λ)))
|
||||
|
||||
;; x and y bound in body
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lc 'e 10 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
|
||||
#:nt (list (select-pattern '(λ (x ...) e))
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern 'x)
|
||||
(select-pattern '(variable-except λ)))
|
||||
#:seq (list (λ () 2)))))
|
||||
'(y x)))
|
||||
|
||||
(let ()
|
||||
(define-language lang (e (variable-prefix pf)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x))
|
||||
#:nt (list (select-pattern '(variable-prefix pf)))))
|
||||
'pfx))
|
||||
|
||||
(let ()
|
||||
(define-language lang (x variable literal))
|
||||
(test (is-nt? lang 'x) #t)
|
||||
(test (is-nt? lang 'x_1) #t)
|
||||
(test (is-nt? lang 'x_!_1) #t)
|
||||
(test (is-nt? lang 'y) #f))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e number (e_1 e_2 e e_1 e_2)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:nt (list (select-pattern '(e_1 e_2 e e_1 e_2))
|
||||
(select-pattern 'number)
|
||||
(select-pattern 'number)
|
||||
(select-pattern 'number))
|
||||
#:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
|
||||
'(2 3 4 2 3)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e (x x_1 x_1) #:binds x x_1)
|
||||
(x variable))
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))
|
||||
#:nt (list (select-pattern '(x x_1 x_1))
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)))))
|
||||
'(x)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e (number_!_1 number_!_2 number_!_1 number_!_2)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:nt (list (select-pattern '(number_!_1 number_!_2 number_!_1 number_!_2)))
|
||||
#:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2) (λ _ 3))))
|
||||
'(1 1 2 3)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a (b_!_1 b_!_1 b_!_1))
|
||||
(b 1 2))
|
||||
(test
|
||||
(with-handlers ([exn:fail? exn-message]) (generate lang 'a 5000 0))
|
||||
#rx"unable"))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e (x_!_1 ...))
|
||||
(x variable))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'y) (λ _ 'z))
|
||||
#:nt (list (select-pattern '(x_!_1 ...))
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable))
|
||||
#:seq (list (λ _ 3))))
|
||||
'(x y z)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e string))
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
|
||||
(cons '(#\g #\i #\n #\r #\s #\t)
|
||||
'("string"))))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a 43)
|
||||
(b (side-condition a_1 (odd? (term a_1))))
|
||||
(c (side-condition a_1 (even? (term a_1))))
|
||||
(d (side-condition (x_1 x_1 x) (not (eq? (term x_1) 'x))) #:binds x_1 x)
|
||||
(e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x))))
|
||||
(x variable))
|
||||
(test (generate lang 'b 5 0) 43)
|
||||
(test (with-handlers ([exn:fail? exn-message])
|
||||
(generate lang 'c 5 0))
|
||||
#rx"unable to generate")
|
||||
(test ; binding works for with side-conditions failure/retry
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'd 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
|
||||
'(y))
|
||||
(test ; mismatch patterns work with side-condition failure/retry
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
|
||||
'(y x y)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a (name x b))
|
||||
(b 4)
|
||||
(c (side-condition (name x d) (zero? (term x))))
|
||||
(d 2 1 0)
|
||||
(e ((side-condition (name d_1 d) (zero? (term d_1))) d_1))
|
||||
(f ((side-condition d_1 (zero? (term d_1))) (name d_1 d))))
|
||||
(test (generate lang 'a 5 0) 4)
|
||||
(test (generate lang 'c 5 0) 0)
|
||||
(test (generate lang 'e 5 0) '(0 0))
|
||||
(test (generate lang 'f 5 0) '(0 0)))
|
||||
|
||||
(define (output-error-port thunk)
|
||||
(let ([port (open-output-string)])
|
||||
(parameterize ([current-error-port port])
|
||||
(thunk))
|
||||
(get-output-string port)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(d 5)
|
||||
(e e 4))
|
||||
(test (output-error-port (λ () (try lang 'e (λ (x) #t))))
|
||||
#rx"No failures")
|
||||
(test (output-error-port (λ () (try lang 'e (λ (x) #f))))
|
||||
"FAILED!\n4\n")
|
||||
(test (output-error-port
|
||||
(λ () (check lang (d_1 e d_2) (equal? '(5 5 4) (term (d_2 d_1 e))) 1 5)))
|
||||
#rx"No failures"))
|
||||
|
||||
(print-tests-passed 'rg-test.ss)
|
||||
393
collects/redex/private/rg.ss
Normal file
393
collects/redex/private/rg.ss
Normal file
|
|
@ -0,0 +1,393 @@
|
|||
#|
|
||||
|
||||
iteratively grow the set of numbers & variables during generation.
|
||||
|
||||
redex: disallow non-terminals on rhs of rules unless they are actually bound(?)
|
||||
|
||||
need support for:
|
||||
- collecting statistics
|
||||
- simplifying test cases
|
||||
|
||||
To do a better job of not generating programs with free variables,
|
||||
keep track of which forms introduce binders
|
||||
and prefer to generate that before generating any variables
|
||||
(also get rid of kludge, as below)
|
||||
|
||||
|#
|
||||
|
||||
#lang scheme
|
||||
|
||||
(require "matcher.ss"
|
||||
"reduction-semantics.ss"
|
||||
"underscore-allowed.ss"
|
||||
"term.ss"
|
||||
mrlib/tex-table)
|
||||
|
||||
(define random-numbers '(0 1 -1 17 8))
|
||||
(define (allow-free-var? [random random]) (= 0 (random 30)))
|
||||
(define (exotic-char? [random random]) (= 0 (random 10)))
|
||||
(define (use-lang-literal? [random random]) (= 0 (random 20)))
|
||||
(define (try-to-introduce-binder?) (= 0 (random 2)) #f)
|
||||
|
||||
(define (hash->keys hash) (hash-map hash (λ (k v) k)))
|
||||
|
||||
(define (lang-literals lang)
|
||||
(define (process-pattern pat lits)
|
||||
(cond [(symbol? pat) (process-pattern (symbol->string pat) lits)]
|
||||
[(string? pat) (hash-set lits pat (void))]
|
||||
[(number? pat) (process-pattern (number->string pat) lits)]
|
||||
[(or (procedure? pat) (boolean? pat) (null? pat)) lits]
|
||||
[(pair? pat) (foldl process-pattern lits pat)]
|
||||
[else (error 'lang-literals "unexpected pattern ~s" pat)]))
|
||||
(define (process-non-terminal nt chars)
|
||||
(foldl (λ (rhs chars) (process-pattern (rhs-pattern rhs) chars))
|
||||
chars (nt-rhs nt)))
|
||||
(hash->keys
|
||||
(foldl process-non-terminal
|
||||
(make-immutable-hash null) (compiled-lang-lang lang))))
|
||||
|
||||
(define (unique-chars strings)
|
||||
(define (record-chars char chars)
|
||||
(if (char=? char #\_) chars (hash-set chars char (void))))
|
||||
(hash->keys
|
||||
(foldl (λ (s c) (foldl record-chars c (string->list s)))
|
||||
(make-immutable-hash null) strings)))
|
||||
|
||||
(define generation-retries 100)
|
||||
(define ascii-chars-threshold 50)
|
||||
(define tex-chars-threshold 500)
|
||||
(define chinese-chars-threshold 2000)
|
||||
|
||||
;; E(pick-length) = 4/5(1 + E(pick-length)) = 4
|
||||
;; P(pick-length >= 50) = 4/5^50 ≈ 0.00143%
|
||||
(define (pick-length [random random])
|
||||
(cond
|
||||
[(zero? (random 5)) 0]
|
||||
[else (+ 1 (pick-length random))]))
|
||||
|
||||
;; pick-length averages about 4, has a max of about 50 and likes the small numbers:
|
||||
#;
|
||||
(let ([l (build-list 100000 (λ (x) (pick-length)))])
|
||||
(values (/ (apply + l) (length l))
|
||||
(apply max l)
|
||||
(let ([ht (make-hash)])
|
||||
(for-each
|
||||
(λ (n) (hash-set! ht n (+ 1 (hash-ref ht n 0))))
|
||||
l)
|
||||
(sort (hash-map ht (λ (x y) (list x (/ y (length l) 1.0))))
|
||||
(λ (x y) (> (cadr x) (cadr y)))))))
|
||||
|
||||
(define (pick-var lang-chars lang-lits bound-vars attempt [random random])
|
||||
;; E(length) = 4/5 + 1/5(1 + E(length)) = 5/4
|
||||
;; P(length=c) = 4/(5^c)
|
||||
(define (length) (if (not (zero? (random 5))) 1 (add1 (length))))
|
||||
(if (or (null? bound-vars) (allow-free-var? random))
|
||||
(string->symbol (random-string lang-chars lang-lits (length) attempt random))
|
||||
(pick-from-list bound-vars random)))
|
||||
|
||||
(define (pick-char attempt lang-chars [random random])
|
||||
(let ([lang (< attempt 50)]
|
||||
[ascii (and (>= attempt ascii-chars-threshold)
|
||||
(< attempt tex-chars-threshold))]
|
||||
[tex (and (>= attempt tex-chars-threshold)
|
||||
(< attempt chinese-chars-threshold))])
|
||||
(if (or lang (not (exotic-char? random)))
|
||||
(pick-from-list lang-chars random)
|
||||
(if (or ascii (not (exotic-char? random)))
|
||||
(let ([i (random (- #x7E #x20 1))]
|
||||
[_ (- (char->integer #\_) #x20)])
|
||||
(integer->char (+ #x20 (if (= i _) (add1 i) i))))
|
||||
(if (or tex (not (exotic-char? random)))
|
||||
(car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))
|
||||
(integer->char (+ #x4E00 (random (- #x9FCF #x4E00)))))))))
|
||||
|
||||
(define (random-string lang-chars lang-lits length attempt [random random])
|
||||
(if (use-lang-literal? random)
|
||||
(pick-from-list lang-lits random)
|
||||
(list->string (build-list length (λ (_) (pick-char attempt lang-chars random))))))
|
||||
|
||||
(define (pick-string lang-chars lang-lits attempt [random random])
|
||||
(random-string lang-chars lang-lits (pick-length random) attempt random))
|
||||
|
||||
(define (pick-nt prods bound-vars size)
|
||||
(let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)]
|
||||
[do-intro-binder? (and (not (zero? size)) (null? bound-vars)
|
||||
(not (null? binders)) (try-to-introduce-binder?))])
|
||||
(pick-from-list (if do-intro-binder? binders prods))))
|
||||
|
||||
(define (pick-from-list l [random random]) (list-ref l (random (length l))))
|
||||
|
||||
(define (min-prods nt base-table)
|
||||
(let* ([sizes (hash-ref base-table (nt-name nt))]
|
||||
[min-size (apply min/f sizes)]
|
||||
[zip (λ (l m) (map cons l m))])
|
||||
(map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
|
||||
|
||||
(define (generation-failure pat)
|
||||
(error 'generate "unable to generate pattern ~s in ~s attempts"
|
||||
pat generation-retries))
|
||||
|
||||
(define (generate lang nt size attempt [decisions@ random-decisions@])
|
||||
(define-values/invoke-unit decisions@
|
||||
(import) (export decisions^))
|
||||
|
||||
(define lang-lits (lang-literals lang))
|
||||
(define lang-chars (unique-chars lang-lits))
|
||||
(define base-table (find-base-cases lang))
|
||||
|
||||
(define (generate-nt nt bound-vars size)
|
||||
(let loop ([nts (compiled-lang-lang lang)])
|
||||
(cond
|
||||
[(null? nts) (error 'generate-nt "didn't find non-terminal ~s" nt)]
|
||||
[(eq? (nt-name (car nts)) nt)
|
||||
(let* ([prods (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))]
|
||||
[rhs ((next-non-terminal-decision) prods bound-vars size)])
|
||||
(generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) (max 0 (sub1 size))))]
|
||||
[else (loop (cdr nts))])))
|
||||
|
||||
(define-struct found-vars (nt source bound-vars found-nt?))
|
||||
(define (generate-pat pat bound-vars var-info size)
|
||||
(let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
|
||||
var-info)]
|
||||
[found-nt? #f]
|
||||
[bindings (make-immutable-hasheq null)]
|
||||
[mismatches (make-immutable-hasheq null)])
|
||||
(let loop ([pat pat])
|
||||
(match pat
|
||||
[`number ((next-number-decision) random-numbers)]
|
||||
[`(variable-except ,vars ...)
|
||||
(let try () (let ([var (loop 'variable)]) (if (memq var vars) (try) var)))]
|
||||
[`variable ((next-variable-decision) lang-chars lang-lits bound-vars attempt)]
|
||||
[`(variable-prefix ,prefix)
|
||||
(string->symbol (string-append (symbol->string prefix) (symbol->string (loop 'variable))))]
|
||||
[`string ((next-string-decision) lang-chars lang-lits attempt)]
|
||||
[`(side-condition ,pattern ,(? procedure? condition))
|
||||
(let ([old-fvt found-vars-table]
|
||||
[old-bindings bindings]
|
||||
[old-mismatches mismatches])
|
||||
(let retry ([remaining generation-retries])
|
||||
(if (zero? remaining)
|
||||
(generation-failure pat)
|
||||
(let ([term (loop pattern)])
|
||||
(if (condition (make-bindings (hash-map bindings (λ (name exp) (make-bind name exp)))))
|
||||
term
|
||||
(begin
|
||||
(set! found-vars-table old-fvt)
|
||||
(set! bindings old-bindings)
|
||||
(set! mismatches old-mismatches)
|
||||
(retry (sub1 remaining))))))))]
|
||||
[`(side-condition ,pattern ,uncompiled-condition)
|
||||
(error 'generate "side-condition not compiled: ~s" pat)]
|
||||
[`(name ,id ,p)
|
||||
(define (generate/record)
|
||||
(let ([term (loop p)])
|
||||
(set! bindings (hash-set bindings id term))
|
||||
term))
|
||||
(hash-ref bindings id generate/record)]
|
||||
[(and (? symbol?) (? (λ (x) (or (is-nt? lang x) (underscored-built-in? x)))))
|
||||
(define (update/generate undecorated decorated)
|
||||
(let* ([new-bound-vars (append (extract-bound-vars decorated found-vars-table) bound-vars)]
|
||||
[term (if (underscored-built-in? pat)
|
||||
(loop undecorated)
|
||||
(generate-nt undecorated new-bound-vars size))])
|
||||
(values term (extend-found-vars decorated term found-vars-table))))
|
||||
(match (symbol->string pat)
|
||||
[(regexp #rx"^([^_]*)_[^_]*$" (list _ undecorated))
|
||||
(hash-ref
|
||||
bindings pat
|
||||
(λ ()
|
||||
(let-values ([(term fvt) (update/generate (string->symbol undecorated) pat)])
|
||||
(set! found-vars-table fvt)
|
||||
(set! bindings (hash-set bindings pat term))
|
||||
term)))]
|
||||
[(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated))
|
||||
(let loop ([remaining generation-retries])
|
||||
(if (zero? remaining)
|
||||
(generation-failure pat)
|
||||
(let-values ([(term fvt) (update/generate (string->symbol undecorated) pat)])
|
||||
(let ([others (hash-ref mismatches pat (λ () null))])
|
||||
(if (member term others)
|
||||
(loop (sub1 remaining))
|
||||
(begin
|
||||
(set! found-vars-table fvt)
|
||||
(set! mismatches
|
||||
(hash-set mismatches pat (cons term others)))
|
||||
term))))))]
|
||||
[else
|
||||
(let-values ([(term fvt) (update/generate pat pat)])
|
||||
(begin (set! found-vars-table fvt) term))])]
|
||||
[(or (? symbol?) (? number?) (? string?) (? boolean?)) pat]
|
||||
[(? null? pat) '()]
|
||||
[(? pair? pat)
|
||||
(if (or (null? (cdr pat))
|
||||
(not (eq? '... (cadr pat))))
|
||||
(cons (loop (car pat))
|
||||
(loop (cdr pat)))
|
||||
(append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat))))
|
||||
(loop (cddr pat))))]
|
||||
[else
|
||||
(error 'generate "unknown pattern ~s\n" pat)]))))
|
||||
|
||||
(define (extract-bound-vars pat found-vars-table)
|
||||
(let loop ([found-vars-table found-vars-table])
|
||||
(cond
|
||||
[(null? found-vars-table) '()]
|
||||
[else (let ([found-vars (car found-vars-table)])
|
||||
(if (eq? pat (found-vars-nt found-vars))
|
||||
(found-vars-bound-vars found-vars)
|
||||
(loop (cdr found-vars-table))))])))
|
||||
|
||||
(define (extend-found-vars pat res found-vars-table)
|
||||
(map
|
||||
(λ (found-vars)
|
||||
(cond
|
||||
[(eq? (found-vars-source found-vars) pat)
|
||||
(let ([new-found-vars
|
||||
(make-found-vars (found-vars-nt found-vars)
|
||||
(found-vars-source found-vars)
|
||||
(cons res (found-vars-bound-vars found-vars))
|
||||
#f)])
|
||||
(when (found-vars-found-nt? found-vars)
|
||||
(error 'generate "kludge in #:binds was exposed! #:binds ~s ~s"
|
||||
(found-vars-nt found-vars)
|
||||
(found-vars-source found-vars)))
|
||||
new-found-vars)]
|
||||
[(eq? (found-vars-nt found-vars) pat)
|
||||
(make-found-vars (found-vars-nt found-vars)
|
||||
(found-vars-source found-vars)
|
||||
(found-vars-bound-vars found-vars)
|
||||
#t)]
|
||||
[else found-vars]))
|
||||
found-vars-table))
|
||||
|
||||
(generate-pat nt '() '() size))
|
||||
|
||||
;; find-base-cases : compiled-language -> hash-table
|
||||
(define (find-base-cases lang)
|
||||
(define nt-table (make-hasheq))
|
||||
(define changed? #f)
|
||||
(define (nt-get nt) (hash-ref nt-table nt 'inf))
|
||||
(define (nt-set nt new)
|
||||
(let ([old (nt-get nt)])
|
||||
(unless (equal? new old)
|
||||
(set! changed? #t)
|
||||
(hash-set! nt-table nt new))))
|
||||
|
||||
(define (process-nt nt)
|
||||
(nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt)))))
|
||||
|
||||
(define (process-rhs rhs)
|
||||
(let ([nts (rhs->nts (rhs-pattern rhs))])
|
||||
(if (null? nts)
|
||||
0
|
||||
(add1/f (apply max/f (map nt-get nts))))))
|
||||
|
||||
;; rhs->path : pattern -> (listof symbol)
|
||||
;; determines all of the non-terminals in a pattern
|
||||
(define (rhs->nts pat)
|
||||
(let ([nts '()])
|
||||
(let loop ([pat pat])
|
||||
(match pat
|
||||
[(? symbol? pat)
|
||||
(when (is-nt? lang pat)
|
||||
(set! nts (cons pat nts)))]
|
||||
[(or (? number?) (? string?) (? procedure?) (? boolean?)) (void)]
|
||||
[`() (void)]
|
||||
[`(,a ,'... . ,b)
|
||||
(loop a)
|
||||
(loop b)]
|
||||
[`(,a . ,b)
|
||||
(loop a)
|
||||
(loop b)]))
|
||||
nts))
|
||||
|
||||
(let loop ()
|
||||
(set! changed? #f)
|
||||
(for-each process-nt (compiled-lang-lang lang))
|
||||
(when changed?
|
||||
(loop)))
|
||||
|
||||
(let ([ht (make-hash)])
|
||||
(for-each
|
||||
(λ (nt) (hash-set! ht (nt-name nt) (map process-rhs (nt-rhs nt))))
|
||||
(compiled-lang-lang lang))
|
||||
ht))
|
||||
|
||||
(define min/f
|
||||
(case-lambda
|
||||
[(a) a]
|
||||
[(a b)
|
||||
(cond
|
||||
[(eq? a 'inf) b]
|
||||
[(eq? b 'inf) a]
|
||||
[else (min a b)])]
|
||||
[(a b . c) (min/f a (apply min/f b c))]))
|
||||
(define max/f
|
||||
(case-lambda
|
||||
[(a) a]
|
||||
[(a b)
|
||||
(cond
|
||||
[(eq? a 'inf) a]
|
||||
[(eq? b 'inf) b]
|
||||
[else (max a b)])]
|
||||
[(a b . c) (max/f a (apply max/f b c))]))
|
||||
(define (add1/f a) (if (eq? a 'inf) 'inf (+ a 1)))
|
||||
|
||||
;; is-nt? : compiled-lang symbol -> boolean
|
||||
(define (is-nt? lang sym)
|
||||
(ormap (λ (nt) (eq? (nt-name nt) (symbol->nt sym)))
|
||||
(compiled-lang-lang lang)))
|
||||
|
||||
;; underscored-built-in? : symbol -> boolean
|
||||
(define (underscored-built-in? sym)
|
||||
(not (false? (memq (symbol->nt sym) underscore-allowed))))
|
||||
|
||||
(define (try lang nt pred? #:attempts [attempts 1000] #:size [size 6])
|
||||
(let loop ([i attempts])
|
||||
(if (zero? i)
|
||||
(fprintf (current-error-port) "No failures in ~a attempts\n" attempts)
|
||||
(let ([t (generate lang nt size (- attempts i))])
|
||||
(if (pred? t)
|
||||
(loop (- i 1))
|
||||
(begin
|
||||
(fprintf (current-error-port) "FAILED!\n")
|
||||
(pretty-print t (current-error-port))))))))
|
||||
|
||||
(define-syntax check
|
||||
(syntax-rules ()
|
||||
[(_ lang (id ...) expr attempts size)
|
||||
(try lang (quote (id ...))
|
||||
(λ (pat)
|
||||
(let-values ([(id ...) (apply values pat)])
|
||||
(term-let ([id id] ...) expr)))
|
||||
#:attempts attempts #:size size)]))
|
||||
|
||||
(define-signature decisions^
|
||||
(next-variable-decision
|
||||
next-number-decision
|
||||
next-non-terminal-decision
|
||||
next-sequence-decision
|
||||
next-string-decision))
|
||||
|
||||
(define random-decisions@
|
||||
(unit (import) (export decisions^)
|
||||
(define (next-variable-decision) pick-var)
|
||||
(define (next-number-decision) pick-from-list)
|
||||
(define (next-non-terminal-decision) pick-nt)
|
||||
(define (next-sequence-decision) pick-length)
|
||||
(define (next-string-decision) pick-string)))
|
||||
|
||||
(define (sexp? x)
|
||||
(or (not (pair? x)) (and (list? x) (andmap sexp? x))))
|
||||
|
||||
(provide pick-from-list pick-var pick-length min-prods decisions^
|
||||
is-nt? lang-literals pick-char random-string pick-string
|
||||
check pick-nt unique-chars)
|
||||
|
||||
(provide/contract
|
||||
[generate any/c]
|
||||
[try (->* (compiled-lang? sexp? (-> any/c any))
|
||||
(#:attempts number? #:size number?)
|
||||
void?)]
|
||||
[find-base-cases (-> compiled-lang? hash?)])
|
||||
|
||||
18
collects/redex/private/run-tests.ss
Normal file
18
collects/redex/private/run-tests.ss
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
;; require this file to run all of the test suites for redex.
|
||||
|
||||
(module run-tests mzscheme
|
||||
(require "pict-test.ss" ;; this one should go last, so it is listed first
|
||||
|
||||
"bitmap-test.ss" ;; second to last
|
||||
|
||||
"core-layout-test.ss"
|
||||
|
||||
"rg-test.ss"
|
||||
"term-test.ss"
|
||||
"tl-test.ss"
|
||||
"matcher-test.ss"
|
||||
"schemeunit-test.ss"
|
||||
"lw-test.ss")
|
||||
|
||||
(printf "\nWARNING: didn't run color-test.ss or subst-test.ss\n"))
|
||||
|
||||
60
collects/redex/private/schemeunit-test.ss
Normal file
60
collects/redex/private/schemeunit-test.ss
Normal file
|
|
@ -0,0 +1,60 @@
|
|||
(module schemeunit-test mzscheme
|
||||
(require "../schemeunit.ss"
|
||||
(all-except "../reduction-semantics.ss" check)
|
||||
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2)))
|
||||
|
||||
(define-language lang
|
||||
(e number (+ e e) (choose e e))
|
||||
(ec hole (+ e ec) (+ ec e))
|
||||
(v number true false))
|
||||
|
||||
(define reductions
|
||||
(reduction-relation
|
||||
lang
|
||||
(--> (in-hole ec_1 (+ number_1 number_2))
|
||||
(in-hole ec_1 ,(+ (term number_1) (term number_2))))
|
||||
(--> (in-hole ec_1 (choose e_1 e_2))
|
||||
(in-hole ec_1 e_1))
|
||||
(--> (in-hole ec_1 (choose e_1 e_2))
|
||||
(in-hole ec_1 e_2))))
|
||||
|
||||
(define tests-passed 0)
|
||||
|
||||
(define (try-it check in out key/vals)
|
||||
(let ([sp (open-output-string)])
|
||||
(parameterize ([current-output-port sp])
|
||||
(test/text-ui (test-case "X" (check reductions in out))))
|
||||
(let ([s (get-output-string sp)])
|
||||
(for-each
|
||||
(λ (key/val)
|
||||
(let* ([key (car key/val)]
|
||||
[val (cadr key/val)]
|
||||
[m (regexp-match (format "\n~a: ([^\n]*)\n" key) s)])
|
||||
(unless m
|
||||
(error 'try-it "didn't find key ~s in ~s" key s))
|
||||
(unless (if (regexp? val)
|
||||
(regexp-match val (cadr m))
|
||||
(equal? val (cadr m)))
|
||||
(error 'try-in "didn't match key ~s, expected ~s got ~s" key val (cadr m)))))
|
||||
key/vals)))
|
||||
(set! tests-passed (+ tests-passed 1)))
|
||||
|
||||
(try-it check-reduces
|
||||
'(choose 1 2)
|
||||
1
|
||||
'((multiple-results "(2 1)")))
|
||||
|
||||
(try-it check-reduces
|
||||
'(+ 1 2)
|
||||
1
|
||||
'((expected "1")
|
||||
(actual "3")))
|
||||
|
||||
(try-it check-reduces/multiple
|
||||
'(+ (choose 3 4) 1)
|
||||
'(4 6)
|
||||
'((expecteds "(4 6)")
|
||||
(actuals #rx"[(][45] [54][)]")))
|
||||
|
||||
(printf "schemeunit-tests: all ~a tests passed.\n" tests-passed))
|
||||
172
collects/redex/private/sexp-diffs.ss
Normal file
172
collects/redex/private/sexp-diffs.ss
Normal file
|
|
@ -0,0 +1,172 @@
|
|||
|
||||
(module sexp-diffs mzscheme
|
||||
(require (lib "pretty.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "list.ss")
|
||||
(lib "graph.ss" "mrlib")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide show-differences find-differences)
|
||||
|
||||
(define (all-but-last l)
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? (cdr l)) null]
|
||||
[else (cons (car l) (loop (cdr l)))])))
|
||||
|
||||
(define (record-differences sexp1 sexp2)
|
||||
(let ([ht (make-hash-table)])
|
||||
;; loop's result indicates if the sexps are different
|
||||
(let loop ([sexp1 sexp1]
|
||||
[sexp2 sexp2])
|
||||
(cond
|
||||
[(eq? sexp1 sexp2) #f]
|
||||
[(and (pair? sexp1)
|
||||
(pair? sexp2)
|
||||
(equal? (d-length sexp1)
|
||||
(d-length sexp2)))
|
||||
(let ([subs-same (map/d loop sexp1 sexp2)])
|
||||
(if (and (andmap values subs-same)
|
||||
(not (= 1 (d-length sexp1))))
|
||||
(begin
|
||||
(hash-table-put! ht sexp1 #t)
|
||||
(hash-table-put! ht sexp2 #t)
|
||||
#t)
|
||||
#f))]
|
||||
[(equal? sexp1 sexp2) #f]
|
||||
[else
|
||||
(hash-table-put! ht sexp1 #t)
|
||||
(hash-table-put! ht sexp2 #t)
|
||||
#t]))
|
||||
ht))
|
||||
|
||||
(define (unwrap s)
|
||||
(cond
|
||||
[(pair? s) (cons (unwrap (car s))
|
||||
(unwrap (cdr s)))]
|
||||
[(wrap? s) (wrap-content s)]
|
||||
[else s]))
|
||||
|
||||
(define (unkink s)
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(pair? s) (cons (loop (car s))
|
||||
(loop (cdr s)))]
|
||||
[(vector? s)
|
||||
(list->vector (map loop (vector->list s)))]
|
||||
[(box? s)
|
||||
(box (loop (unbox s)))]
|
||||
[(number? s) (make-wrap s)]
|
||||
[(symbol? s) (make-wrap s)]
|
||||
[else s])))
|
||||
|
||||
(define-struct wrap (content) (make-inspector))
|
||||
|
||||
(define (show-differences orig-s1 orig-s2 columns)
|
||||
(let-values ([(to-color-s1 to-color-s2)
|
||||
(find-differences orig-s1 orig-s2 columns columns)])
|
||||
(define f (new frame% [label ""] [width 600] [height 500]))
|
||||
(define hp (new horizontal-panel% [parent f]))
|
||||
(define t1 (new text:basic%))
|
||||
(define t2 (new text:basic%))
|
||||
(define c1 (new editor-canvas%
|
||||
[parent hp]
|
||||
[editor t1]))
|
||||
(define c2 (new editor-canvas%
|
||||
[parent hp]
|
||||
[editor t2]))
|
||||
(render-sexp/colors orig-s1 to-color-s1 t1 columns)
|
||||
(render-sexp/colors orig-s2 to-color-s2 t2 columns)
|
||||
(send f show #t)))
|
||||
|
||||
(define (find-differences orig-s1 orig-s2 columns1 columns2)
|
||||
(let ([s1 (unkink orig-s1)]
|
||||
[s2 (unkink orig-s2)])
|
||||
(define diff-ht (record-differences s1 s2))
|
||||
(values (find-coloring s1 diff-ht columns1)
|
||||
(find-coloring s2 diff-ht columns2))))
|
||||
|
||||
;; render-sexp/colors : sexp ht text -> void
|
||||
(define (render-sexp/colors sexp to-color text columns)
|
||||
(let ([start '()])
|
||||
(parameterize ([pretty-print-columns columns]
|
||||
[pretty-print-abbreviate-read-macros #f])
|
||||
(pretty-print sexp (open-output-text-editor text)))
|
||||
(for-each
|
||||
(λ (p) (send text highlight-range (car p) (cdr p) (send the-color-database find-color "NavajoWhite")))
|
||||
to-color)
|
||||
(send text change-style
|
||||
(make-object style-delta% 'change-family 'modern)
|
||||
0
|
||||
(send text last-position))))
|
||||
|
||||
(define (find-coloring sexp diff-ht columns)
|
||||
(let* ([start '()]
|
||||
[to-color '()]
|
||||
[pending-bytes (bytes)]
|
||||
[position 0]
|
||||
[counting-port
|
||||
(make-output-port 'counting-port
|
||||
always-evt
|
||||
(λ (bs start end can-block? breaks?)
|
||||
(cond
|
||||
[(= 0 (bytes-length bs))
|
||||
0]
|
||||
[else
|
||||
(set! pending-bytes (bytes-append pending-bytes (bytes (bytes-ref bs start))))
|
||||
(let ([str (with-handlers ([exn:fail:contract? (λ (x) #f)])
|
||||
(bytes->string/utf-8 pending-bytes))])
|
||||
(when str
|
||||
(set! position (+ position (string-length str)))
|
||||
(set! pending-bytes (bytes))))
|
||||
1]))
|
||||
void)])
|
||||
(parameterize ([pretty-print-columns columns]
|
||||
[pretty-print-abbreviate-read-macros #f]
|
||||
[pretty-print-remap-stylable
|
||||
(λ (val)
|
||||
(and (wrap? val)
|
||||
(symbol? (wrap-content val))
|
||||
(wrap-content val)))]
|
||||
[pretty-print-size-hook
|
||||
(λ (val dsp? port)
|
||||
(if (wrap? val)
|
||||
(string-length (format "~s" (wrap-content val)))
|
||||
#f))]
|
||||
[pretty-print-print-hook
|
||||
(λ (val dsp? port)
|
||||
(write (wrap-content val) port))]
|
||||
[pretty-print-pre-print-hook
|
||||
(λ (obj port)
|
||||
(when (hash-table-get diff-ht obj #f)
|
||||
(flush-output port)
|
||||
(set! start (cons position start))))]
|
||||
[pretty-print-post-print-hook
|
||||
(λ (obj port)
|
||||
(when (hash-table-get diff-ht obj #f)
|
||||
(flush-output port)
|
||||
(set! to-color (cons (cons (car start) position) to-color))
|
||||
(set! start (cdr start))))])
|
||||
(pretty-print sexp counting-port))
|
||||
to-color))
|
||||
|
||||
;; does a map-like operation, but if the list is dotted, flattens the results into an actual list.
|
||||
(define (map/d f l1 l2)
|
||||
(let loop ([l1 l1]
|
||||
[l2 l2])
|
||||
(cond
|
||||
[(pair? l1)
|
||||
(cons (f (car l1) (car l2))
|
||||
(loop (cdr l1) (cdr l2)))]
|
||||
[(null? l1) null]
|
||||
[else (list (f l1 l2))])))
|
||||
|
||||
(define (d-length l1)
|
||||
(let loop ([l1 l1]
|
||||
[n 0])
|
||||
(cond
|
||||
[(pair? l1) (loop (cdr l1) (+ n 1))]
|
||||
[(null? l1) n]
|
||||
[else (cons 'dotted (+ n 1))]))))
|
||||
182
collects/redex/private/size-snip.ss
Normal file
182
collects/redex/private/size-snip.ss
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
(module size-snip mzscheme
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "framework.ss" "framework"))
|
||||
|
||||
(provide reflowing-snip<%>
|
||||
size-editor-snip%
|
||||
default-pretty-printer
|
||||
initial-char-width
|
||||
resizing-pasteboard-mixin)
|
||||
|
||||
(define initial-char-width (make-parameter 30))
|
||||
|
||||
(define (default-pretty-printer v port w spec)
|
||||
(parameterize ([pretty-print-columns w])
|
||||
(pretty-print v port)))
|
||||
|
||||
(define reflowing-snip<%>
|
||||
(interface ()
|
||||
reflow-program))
|
||||
|
||||
(define (resizing-pasteboard-mixin pb%)
|
||||
(class pb%
|
||||
(init-field shrink-down?)
|
||||
|
||||
(define/augment (on-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) on-interactive-resize snip))
|
||||
|
||||
(define/augment (after-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) after-interactive-resize snip))
|
||||
|
||||
(define/override (interactive-adjust-resize snip w h)
|
||||
(super interactive-adjust-resize snip w h)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program)))
|
||||
|
||||
(inherit get-snip-location
|
||||
begin-edit-sequence
|
||||
end-edit-sequence)
|
||||
|
||||
(define/augment (on-insert snip before x y)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-insert snip before x y))
|
||||
(define/augment (after-insert snip before x y)
|
||||
(inner (void) after-insert snip before x y)
|
||||
(when (is-a? snip size-editor-snip%)
|
||||
(let ([cw (send snip get-char-width)]
|
||||
[woc (send snip get-width-of-char)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-snip-location snip #f bt #f)
|
||||
(get-snip-location snip #f bb #t)
|
||||
(send snip resize
|
||||
(* cw woc)
|
||||
(- (unbox bb) (unbox bt)))
|
||||
(when shrink-down?
|
||||
(send snip shrink-down))))
|
||||
(end-edit-sequence))
|
||||
(super-new)))
|
||||
|
||||
(define size-editor-snip%
|
||||
(class* editor-snip% (reflowing-snip<%>)
|
||||
(init-field expr)
|
||||
(init pp)
|
||||
(init-field char-width)
|
||||
(define real-pp
|
||||
(if (procedure-arity-includes? pp 4)
|
||||
pp
|
||||
(lambda (v port w spec) (display (pp v) port))))
|
||||
(inherit get-admin)
|
||||
(define/public (get-expr) expr)
|
||||
(define/public (get-char-width) char-width)
|
||||
|
||||
(define/override (resize w h)
|
||||
(super resize w h)
|
||||
(reflow-program))
|
||||
|
||||
(inherit get-editor)
|
||||
;; final
|
||||
(define/pubment (reflow-program)
|
||||
(let* ([tw (get-width-of-char)]
|
||||
[sw (get-snip-width)])
|
||||
(when (and tw sw)
|
||||
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
|
||||
(unless (equal? new-width char-width)
|
||||
(set! char-width new-width)
|
||||
(format-expr)
|
||||
(on-width-changed char-width))))))
|
||||
|
||||
;; final
|
||||
(define/pubment (shrink-down)
|
||||
(let ([ed (get-editor)]
|
||||
[bx (box 0)]
|
||||
[by (box 0)])
|
||||
(let ([max-line-width
|
||||
(let loop ([p 0]
|
||||
[max-w 0])
|
||||
(cond
|
||||
[(<= p (send ed last-paragraph))
|
||||
(send ed position-location
|
||||
(send ed paragraph-end-position p)
|
||||
bx by #t)
|
||||
(let ([this-w (unbox bx)])
|
||||
(loop (+ p 1)
|
||||
(max this-w max-w)))]
|
||||
[else max-w]))])
|
||||
(send ed position-location (send ed last-position) bx by #f)
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(super resize
|
||||
(+ max-line-width hms)
|
||||
(+ (unbox by) vms))))))
|
||||
|
||||
(inherit get-margin)
|
||||
(define/public (get-snip-width)
|
||||
(let ([admin (get-admin)])
|
||||
(and admin
|
||||
(let ([containing-editor (send admin get-editor)]
|
||||
[bl (box 0)]
|
||||
[br (box 0)])
|
||||
(send containing-editor get-snip-location this bl #f #f)
|
||||
(send containing-editor get-snip-location this br #f #t)
|
||||
(let ([outer-w (- (unbox br) (unbox bl))])
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(- outer-w hms)))))))
|
||||
|
||||
(define/private (get-margin-space)
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-margin bl bt br bb)
|
||||
(values (+ (unbox bl) (unbox br) 2) ;; not sure what the 2 is for. Maybe caret space?
|
||||
(+ (unbox bt) (unbox bb)))))
|
||||
|
||||
(define/public (get-width-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
tw))))))
|
||||
|
||||
(define/public (get-height-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
th))))))
|
||||
|
||||
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
|
||||
|
||||
(define/public (format-expr)
|
||||
(let* ([text (get-editor)]
|
||||
[port (open-output-text-editor text)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text thaw-colorer))
|
||||
(send text set-styles-sticky #f)
|
||||
(send text erase)
|
||||
(real-pp expr port char-width text)
|
||||
(unless (zero? (send text last-position))
|
||||
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
|
||||
(send text delete (- (send text last-position) 1) (send text last-position))))
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text freeze-colorer))
|
||||
(send text end-edit-sequence)))
|
||||
|
||||
(super-new)
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t))))
|
||||
882
collects/redex/private/stepper.ss
Normal file
882
collects/redex/private/stepper.ss
Normal file
|
|
@ -0,0 +1,882 @@
|
|||
#|
|
||||
|
||||
todo:
|
||||
|
||||
- tree diff
|
||||
|
||||
- step until a particular reduction happens (or a choice point is reached)
|
||||
|
||||
- break points: supply a function to traces that is a predicate on terms, indicating if
|
||||
this one is one where the -> button should stop.
|
||||
|
||||
|#
|
||||
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/pretty
|
||||
scheme/gui/base
|
||||
scheme/list
|
||||
scheme/class
|
||||
framework
|
||||
mrlib/graph
|
||||
scheme/contract
|
||||
"sexp-diffs.ss"
|
||||
"size-snip.ss"
|
||||
"reduction-semantics.ss")
|
||||
|
||||
(provide stepper stepper/seed)
|
||||
|
||||
(define dot-spacing 20)
|
||||
(define dot-size 10)
|
||||
(define initial-color "white")
|
||||
(define in-path-color "orchid")
|
||||
(define visible-color "purple")
|
||||
(define cycle-color "yellow")
|
||||
(define visible-cycle-color "gold")
|
||||
|
||||
(define (pick-label candidate fallback)
|
||||
(cond
|
||||
[(andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t))
|
||||
(string->list candidate))
|
||||
candidate]
|
||||
[else
|
||||
fallback]))
|
||||
|
||||
;; initial-button-label is just used to give some space to the buttons on non-mac platforms
|
||||
(define initial-button-label (pick-label "↩→↕" "<->-"))
|
||||
|
||||
(define forward-label (pick-label "→" "->"))
|
||||
(define updown-label (pick-label "↕" "^"))
|
||||
(define back-label (pick-label "↩" "<-"))
|
||||
|
||||
(define (stepper red term [pp default-pretty-printer])
|
||||
(stepper/seed red (list term) pp))
|
||||
|
||||
(define (stepper/seed red seed [pp default-pretty-printer])
|
||||
(define term (car seed))
|
||||
;; all-nodes-ht : hash[sexp -o> (is-a/c node%)]
|
||||
(define all-nodes-ht (make-hash))
|
||||
|
||||
(define root (new node%
|
||||
[pp pp]
|
||||
[all-nodes-ht all-nodes-ht]
|
||||
[term term]
|
||||
[red red]
|
||||
[change-path (λ (new-node) (change-path new-node))]
|
||||
[init-cw (initial-char-width)]))
|
||||
|
||||
;; path : (listof (listof (is-a/c node%))
|
||||
;; the currently visible columns in the pasteboard
|
||||
(define path (cons (list root) '()))
|
||||
|
||||
(define f (new frame%
|
||||
[label "PLT Redex Stepper"]
|
||||
[width 700]
|
||||
[height 450]))
|
||||
(define dp (new vertical-panel% [parent f]))
|
||||
(define upper-hp (new horizontal-panel% [parent dp]))
|
||||
(define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
|
||||
(define pb (new columnar-pasteboard%
|
||||
[shrink-down? #f]
|
||||
[moved (λ (a b c d)
|
||||
(when (procedure? moved)
|
||||
(moved a b c d)))]))
|
||||
(define ec (new forward-size-editor-canvas% [parent upper-hp] [editor pb] [style '(#;no-vscroll)]))
|
||||
(define bp-outer (new vertical-panel% [parent upper-hp] [stretchable-width #f]))
|
||||
(define bp (new vertical-panel% [parent bp-outer] [stretchable-width #f]))
|
||||
(define bp-spacer (new grow-box-spacer-pane% [parent bp-outer]))
|
||||
|
||||
(define zoom-out-pb (new zoom-out-pasteboard%))
|
||||
(define zoom-out-ec (new editor-canvas%
|
||||
[stretchable-height #t]
|
||||
[parent lower-hp]
|
||||
[style '(hide-vscroll)]
|
||||
[editor zoom-out-pb]))
|
||||
|
||||
(define choice-vp (new vertical-panel% [alignment '(center center)] [parent lower-hp] [stretchable-width #f]))
|
||||
(define reduction-names (reduction-relation->rule-names red))
|
||||
(define reds-choice
|
||||
(and (not (null? reduction-names))
|
||||
(new choice%
|
||||
[parent choice-vp]
|
||||
[font small-control-font]
|
||||
[label #f]
|
||||
[choices (cons "Single Step"
|
||||
(map (λ (x) (format "Reduce until ~a" x))
|
||||
reduction-names))])))
|
||||
(define red-name-message
|
||||
(and (not (null? (reduction-relation->rule-names red)))
|
||||
(new message%
|
||||
[parent choice-vp]
|
||||
[stretchable-width #t]
|
||||
[font small-control-font]
|
||||
[label ""])))
|
||||
(define stupid-internal-definition-syntax1 (new grow-box-spacer-pane% [parent lower-hp]))
|
||||
|
||||
(define (update-buttons)
|
||||
(let ([last-column (last path)])
|
||||
(let ([last-column last-column])
|
||||
(let loop ([children (send bp get-children)]
|
||||
[n 0])
|
||||
(cond
|
||||
[(= n (length last-column))
|
||||
(send bp change-children
|
||||
(λ (l)
|
||||
(filter (λ (p) (not (memq p children))) l)))
|
||||
(void)]
|
||||
[(null? children)
|
||||
(new button-object%
|
||||
[parent bp]
|
||||
[n n])
|
||||
(loop children
|
||||
(+ n 1))]
|
||||
[else
|
||||
(loop (cdr children)
|
||||
(+ n 1))])))
|
||||
(let ([button-objects (send bp get-children)])
|
||||
(if (null? (cdr button-objects))
|
||||
(send (car button-objects) hide-vertical)
|
||||
(for-each (λ (x) (send x show-vertical))
|
||||
button-objects))
|
||||
(for-each (λ (node button-object)
|
||||
(cond
|
||||
[(not (null? (send node get-cycle)))
|
||||
(send button-object step-goes-back #t)
|
||||
(send button-object enable-step #f)]
|
||||
[else
|
||||
(send button-object step-goes-back #f)
|
||||
(send button-object enable-step (not (null? (send node get-successors))))]))
|
||||
last-column
|
||||
button-objects))))
|
||||
|
||||
(define button-object%
|
||||
(class vertical-panel%
|
||||
(init-field n)
|
||||
(super-new [style '(border)]
|
||||
[alignment '(left center)])
|
||||
|
||||
(inherit change-children)
|
||||
(define/public (hide-vertical)
|
||||
(change-children (λ (x) (remq expand-button x))))
|
||||
(define/public (show-vertical)
|
||||
(change-children (λ (x) (if (memq expand-button x)
|
||||
x
|
||||
(append x (list expand-button))))))
|
||||
|
||||
(define/public (enable-step on?)
|
||||
(send step-button enable on?))
|
||||
|
||||
(define/public (step-goes-back back?)
|
||||
(send step-button set-label
|
||||
(if back?
|
||||
back-label
|
||||
forward-label)))
|
||||
|
||||
(define step-button
|
||||
(new button%
|
||||
[label initial-button-label]
|
||||
[callback (λ (x y) (forward-step n))]
|
||||
[parent this]))
|
||||
(define expand-button
|
||||
(new button%
|
||||
[label initial-button-label]
|
||||
[callback (λ (x y) (expand n))]
|
||||
[parent this]))
|
||||
|
||||
(send step-button set-label forward-label)
|
||||
(send expand-button set-label updown-label)))
|
||||
|
||||
(define (forward-step n)
|
||||
(let* ([last-pr (last-pair path)]
|
||||
[last-column (car last-pr)]
|
||||
[click-target (list-ref last-column n)])
|
||||
(cond
|
||||
[(not (null? (send click-target get-cycle)))
|
||||
(void)]
|
||||
[else
|
||||
(let ([new-path-tail (iterate-until-done click-target)])
|
||||
(for-each (λ (x) (send x set-in-path? (eq? x click-target))) last-column)
|
||||
(for-each (λ (new-children)
|
||||
(for-each (λ (x) (send x set-in-path? #t)) new-children))
|
||||
new-path-tail)
|
||||
(set! path
|
||||
(let loop ([path path])
|
||||
(cond
|
||||
[(null? (cdr path))
|
||||
(cons (list click-target)
|
||||
new-path-tail)]
|
||||
[else (cons (car path) (loop (cdr path)))])))
|
||||
(update-everything)
|
||||
(update-highlight-to-end))])))
|
||||
|
||||
;; iterate-until-done : node -> (listof (listof node))
|
||||
;; iterates forward in the path until a choice point is reached
|
||||
;; or until we hit a stopping point. return the new tail of the path
|
||||
(define (iterate-until-done click-target)
|
||||
(let ([looking-for
|
||||
(cond
|
||||
[(or (not reds-choice)
|
||||
(zero? (send reds-choice get-selection)))
|
||||
#f]
|
||||
[else (list-ref reduction-names (- (send reds-choice get-selection) 1))])])
|
||||
(let loop ([next-node click-target]
|
||||
[new-nodes (list)]
|
||||
[cutoff (if looking-for
|
||||
100
|
||||
1)])
|
||||
(cond
|
||||
[(zero? cutoff) (reverse new-nodes)]
|
||||
[else
|
||||
(let ([new-children (begin (send next-node force)
|
||||
(send next-node get-children))])
|
||||
(cond
|
||||
[(null? new-children)
|
||||
(reverse new-nodes)]
|
||||
[(null? (cdr new-children))
|
||||
(cond
|
||||
[(send (car new-children) in-cycle?)
|
||||
(reverse (cons new-children new-nodes))]
|
||||
[(equal? (find-reduction-label next-node (car new-children))
|
||||
looking-for)
|
||||
(reverse (cons new-children new-nodes))]
|
||||
[else
|
||||
(loop (car new-children)
|
||||
(cons new-children new-nodes)
|
||||
(- cutoff 1))])]
|
||||
[else
|
||||
(reverse (cons new-children new-nodes))]))]))))
|
||||
|
||||
(define (expand n)
|
||||
(let* ([last-pr (last-pair path)]
|
||||
[last-column (car last-pr)]
|
||||
[survivor (list-ref last-column n)])
|
||||
(for-each (λ (x) (send x set-in-path? (eq? x survivor))) last-column)
|
||||
(set! path
|
||||
(let loop ([path path])
|
||||
(cond
|
||||
[(null? (cdr path))
|
||||
(cons (list survivor) '())]
|
||||
[else
|
||||
(cons (car path) (loop (cdr path)))])))
|
||||
(update-everything)
|
||||
(update-highlight-to-end)))
|
||||
|
||||
(define (moved left top right bottom)
|
||||
(let ([bx (box 0)])
|
||||
(let loop ([path path])
|
||||
(cond
|
||||
[(null? path) (void)]
|
||||
[else
|
||||
(let* ([path-ele (car path)]
|
||||
[snip (send (car path-ele) get-big-snip)]
|
||||
[visible?
|
||||
(or (begin (send pb get-snip-location snip bx #f #f)
|
||||
(<= left (unbox bx) right))
|
||||
(begin (send pb get-snip-location snip bx #f #t)
|
||||
(<= left (unbox bx) right)))])
|
||||
(for-each (λ (node) (send node set-visible? visible?))
|
||||
path-ele))
|
||||
(loop (cdr path))]))))
|
||||
|
||||
(define (get-path-to-root node)
|
||||
(let loop ([node node]
|
||||
[acc null])
|
||||
(let ([parents (send node get-parents)])
|
||||
(cond
|
||||
[(null? parents) (cons (list node) acc)]
|
||||
[node (loop (car parents)
|
||||
(cons (list node) acc))]))))
|
||||
|
||||
(define (change-path new-node)
|
||||
(cond
|
||||
[(ormap (λ (l) (memq new-node l)) path)
|
||||
;; if this node is in the current path, just move the view
|
||||
(let* ([snip (send new-node get-big-snip)]
|
||||
[br (box 0)])
|
||||
(send pb get-snip-location snip br #f #t)
|
||||
(let ([bw (box 0)]
|
||||
[bh (box 0)])
|
||||
(send (send (send ec get-editor) get-admin) get-view #f #f bw bh)
|
||||
(let* ([x (max 0 (- (unbox br) (unbox bw)))])
|
||||
(send ec scroll-to x 0.0 (- (unbox bw) 4) (- (unbox bh) 1) #t 'end))))]
|
||||
[else
|
||||
(let ([new-path (get-path-to-root new-node)])
|
||||
(let loop ([new-path new-path]
|
||||
[path path])
|
||||
(cond
|
||||
[(or (null? path)
|
||||
(null? new-path)
|
||||
(not (equal? (car path) (car new-path))))
|
||||
(for-each (λ (old-ele) (for-each (λ (x) (send x set-in-path? #f)) old-ele))
|
||||
path)
|
||||
(for-each (λ (old-ele) (for-each (λ (x) (send x set-in-path? #t)) old-ele))
|
||||
new-path)]
|
||||
[else
|
||||
(loop (cdr new-path) (cdr path))]))
|
||||
|
||||
(set! path new-path)
|
||||
(update-everything))])
|
||||
(update-highlight-to-node-and-parent new-node))
|
||||
|
||||
(define (update-everything)
|
||||
(send pb begin-edit-sequence)
|
||||
(pb-change-columns)
|
||||
(pb-last-column-visible)
|
||||
(send pb end-edit-sequence)
|
||||
(update-buttons))
|
||||
|
||||
(define (update-highlight-to-end)
|
||||
(let-values ([(one-col-before last-column)
|
||||
(let loop ([path path]
|
||||
[one-before #f]
|
||||
[last-one #f])
|
||||
(cond
|
||||
[(null? path) (values one-before last-one)]
|
||||
[else (loop (cdr path)
|
||||
last-one
|
||||
(car path))]))])
|
||||
(when (and one-col-before
|
||||
last-column
|
||||
(= 1 (length one-col-before))
|
||||
(= 1 (length last-column)))
|
||||
(set-highlight (car one-col-before)
|
||||
(car last-column)))))
|
||||
|
||||
(define (update-highlight-to-node-and-parent node)
|
||||
(let* ([all-parents (send node get-parents)]
|
||||
[visible-parent
|
||||
(ormap (λ (x) (and (memq x all-parents) x))
|
||||
(apply append path))])
|
||||
(when visible-parent
|
||||
(set-highlight visible-parent node))))
|
||||
|
||||
(define (set-highlight parent child)
|
||||
(for-each
|
||||
(λ (col)
|
||||
(for-each (λ (node) (send (send node get-big-snip) clear-diffs))
|
||||
col))
|
||||
path)
|
||||
(let-values ([(to-color1 to-color2)
|
||||
(find-differences
|
||||
(send parent get-term)
|
||||
(send child get-term)
|
||||
(send (send parent get-big-snip) get-char-width)
|
||||
(send (send child get-big-snip) get-char-width))])
|
||||
(send (send parent get-big-snip) highlight-diffs to-color1)
|
||||
(send (send child get-big-snip) highlight-diffs to-color2)
|
||||
(void))
|
||||
|
||||
(when red-name-message
|
||||
(let ([label (map (λ (x) (if x (format "[~a]" x) "≪unknown≫"))
|
||||
(find-reduction-label parent child))])
|
||||
(cond
|
||||
[(null? label) (void)]
|
||||
[(null? (cdr label))
|
||||
(send red-name-message set-label (car label))]
|
||||
[else
|
||||
(apply
|
||||
string-append
|
||||
(car label)
|
||||
(map (λ (x) (format " and ~a" x))
|
||||
(cdr label)))]))))
|
||||
|
||||
(define (find-reduction-label parent child)
|
||||
(let ([children (send parent get-children)])
|
||||
(and children
|
||||
(let loop ([children children]
|
||||
[red-names (send parent get-successor-names)])
|
||||
(cond
|
||||
[(null? children) #f]
|
||||
[else
|
||||
(if (eq? (car children) child)
|
||||
(car red-names)
|
||||
(loop (cdr children)
|
||||
(cdr red-names)))])))))
|
||||
|
||||
(define (pb-change-columns)
|
||||
(send pb change-columns (map (λ (l) (map (λ (x) (send x get-big-snip)) l))
|
||||
path))
|
||||
(send zoom-out-pb refresh-tree root))
|
||||
|
||||
;; makes the last column visible
|
||||
(define (pb-last-column-visible)
|
||||
(for-each
|
||||
(λ (x)
|
||||
(let ([admin (send pb get-admin)])
|
||||
(when admin
|
||||
(let ([w (box 0)]
|
||||
[h (box 0)]
|
||||
[sr (box 0)]
|
||||
[s (send x get-big-snip)])
|
||||
(send admin get-view #f #f w h)
|
||||
(send pb get-snip-location s #f sr #t)
|
||||
'(send ec scroll-to
|
||||
(max 0 (- (unbox sr) (unbox w)))
|
||||
0
|
||||
(unbox w)
|
||||
(unbox h)
|
||||
#t)))))
|
||||
(car (last-pair path))))
|
||||
|
||||
(hash-set! all-nodes-ht term root)
|
||||
(send root set-in-path? #t)
|
||||
|
||||
(let loop ([term (car seed)]
|
||||
[last-nexts #f]
|
||||
[terms (cdr seed)])
|
||||
|
||||
(when last-nexts
|
||||
(expand (find-i term last-nexts void)))
|
||||
(cond
|
||||
[(null? terms) (void)]
|
||||
[else
|
||||
(let* ([nexts (apply-reduction-relation red term)]
|
||||
[ith (find-i (car terms)
|
||||
nexts
|
||||
(λ ()
|
||||
(error 'stepper "term ~s does not reduce to ~s"
|
||||
term
|
||||
(car terms))))])
|
||||
(forward-step 0)
|
||||
(loop (car terms)
|
||||
nexts
|
||||
(cdr terms)))]))
|
||||
|
||||
(send f show #t)
|
||||
(pb-change-columns)
|
||||
(update-buttons))
|
||||
|
||||
(define (find-i term terms fail)
|
||||
(let loop ([i 0]
|
||||
[terms terms])
|
||||
(cond
|
||||
[(null? terms) (fail)]
|
||||
[(equal? (car terms) term) i]
|
||||
[else (loop (+ i 1) (cdr terms))])))
|
||||
|
||||
(define node%
|
||||
(class object%
|
||||
(init-field term
|
||||
red
|
||||
change-path
|
||||
all-nodes-ht
|
||||
pp
|
||||
init-cw)
|
||||
(init [parent #f])
|
||||
|
||||
(define parents (if parent
|
||||
(list parent)
|
||||
'()))
|
||||
;; cycle : (listof node)
|
||||
;; the nodes that have the same term as this one, due to a cycle in the reduction graph
|
||||
(define cycle '())
|
||||
(define children #f)
|
||||
(define big-snip (mk-big-snip term this pp init-cw))
|
||||
(define dot-snip (new dot-snip% [node this]))
|
||||
(define in-path? #f)
|
||||
(define visible? #f)
|
||||
|
||||
(define successors #f)
|
||||
|
||||
;; #f => uninited, else
|
||||
;; (listof (listof string))
|
||||
;; one list element for each successor, one nested list element for each reduction that applied (typically 1)
|
||||
(define successor-names #f)
|
||||
(define/public (get-successors)
|
||||
(unless successors
|
||||
(let ([names/succs (apply-reduction-relation/tag-with-names red term)]
|
||||
[ht (make-hash)])
|
||||
(for-each (λ (name/succ)
|
||||
(let ([name (car name/succ)]
|
||||
[succ (cadr name/succ)])
|
||||
(hash-set! ht succ (cons name (hash-ref ht succ '())))))
|
||||
names/succs)
|
||||
(let ([merged-names/succs
|
||||
(let loop ([succs (map cadr names/succs)])
|
||||
(cond
|
||||
[(null? succs) null]
|
||||
[else
|
||||
(let ([succ (car succs)])
|
||||
(if (hash-ref ht succ)
|
||||
(cons (begin0 (list (hash-ref ht succ) succ)
|
||||
(hash-set! ht succ #f))
|
||||
(loop (cdr succs)))
|
||||
(loop (cdr succs))))]))])
|
||||
(set! successor-names (map car merged-names/succs))
|
||||
(set! successors (map cadr merged-names/succs)))))
|
||||
successors)
|
||||
(define/public (get-successor-names)
|
||||
(get-successors) ;; force the variables to be defined
|
||||
successor-names)
|
||||
|
||||
(define/public (move-path)
|
||||
(change-path this))
|
||||
|
||||
(define/public (set-in-path? p?)
|
||||
(set! in-path? p?)
|
||||
(update-color))
|
||||
|
||||
(define/public (set-visible? v?)
|
||||
(set! visible? v?)
|
||||
(update-color))
|
||||
|
||||
(define/private (update-color)
|
||||
(send dot-snip set-color
|
||||
(cond
|
||||
[(and visible? in-path? (not (null? cycle)))
|
||||
visible-cycle-color]
|
||||
[(not (null? cycle))
|
||||
cycle-color]
|
||||
[(and visible? in-path?)
|
||||
visible-color]
|
||||
[in-path?
|
||||
in-path-color]
|
||||
[else
|
||||
initial-color])))
|
||||
|
||||
(define/public (get-cycle) cycle)
|
||||
(define/public (add-cycle c) (set! cycle (cons c (remq c cycle))))
|
||||
(define/public (in-cycle?) (not (null? cycle)))
|
||||
(define/public (get-term) term)
|
||||
(define/public (get-big-snip) big-snip)
|
||||
(define/public (get-dot-snip) dot-snip)
|
||||
(define/public (get-parents) parents)
|
||||
(define/public (add-parent p)
|
||||
(add-links (send p get-dot-snip) dot-snip)
|
||||
(set! parents (cons p parents)))
|
||||
(define/public (get-children) (or children '()))
|
||||
(define/public (force)
|
||||
(unless children
|
||||
(set! children
|
||||
(map (λ (x) (make-child x)) (get-successors)))))
|
||||
|
||||
(define/private (make-child term)
|
||||
(let ([already-there (hash-ref all-nodes-ht term #f)]
|
||||
[mk-child-node
|
||||
(λ ()
|
||||
(new node%
|
||||
[pp pp]
|
||||
[term term]
|
||||
[red red]
|
||||
[change-path change-path]
|
||||
[all-nodes-ht all-nodes-ht]
|
||||
[parent this]
|
||||
[init-cw init-cw]))])
|
||||
(cond
|
||||
[(and already-there
|
||||
(or (eq? this already-there)
|
||||
(is-parent? already-there)))
|
||||
(let ([n (mk-child-node)])
|
||||
(send n add-cycle already-there)
|
||||
(send already-there add-cycle n)
|
||||
n)]
|
||||
[already-there
|
||||
(send already-there add-parent this)
|
||||
already-there]
|
||||
[else
|
||||
(let ([child-node (mk-child-node)])
|
||||
(hash-set! all-nodes-ht term child-node)
|
||||
child-node)])))
|
||||
|
||||
(define/private (is-parent? node)
|
||||
(let loop ([parents (get-parents)])
|
||||
(ormap (λ (p)
|
||||
(or (eq? p node)
|
||||
(loop (send p get-parents))))
|
||||
parents)))
|
||||
|
||||
(super-new)
|
||||
(when cycle
|
||||
(send dot-snip set-color cycle-color))
|
||||
(when parent
|
||||
(add-links (send parent get-dot-snip) dot-snip))))
|
||||
|
||||
(define zoom-out-pasteboard%
|
||||
(class (graph-pasteboard-mixin pasteboard%)
|
||||
(inherit insert move-to get-canvas get-admin)
|
||||
|
||||
(inherit find-snip set-caret-owner global-to-local)
|
||||
(define/override (on-event evt)
|
||||
(when (send evt button-down?)
|
||||
(let ([x (box (send evt get-x))]
|
||||
[y (box (send evt get-y))])
|
||||
(global-to-local x y)
|
||||
(let ([s (find-snip (unbox x) (unbox y))])
|
||||
(when s
|
||||
(set-caret-owner s 'immediate)))))
|
||||
(super on-event evt))
|
||||
|
||||
(define/public (refresh-tree root)
|
||||
(let ([level-ht (make-hasheq)]
|
||||
[node-to-level-ht (make-hasheq)]
|
||||
[max-n 0])
|
||||
|
||||
(let loop ([tree root]
|
||||
[n 0])
|
||||
(let ([old-level (hash-ref node-to-level-ht tree #f)])
|
||||
(cond
|
||||
[(not old-level)
|
||||
(hash-set! node-to-level-ht tree n)
|
||||
(hash-set! level-ht n (cons tree (hash-ref level-ht n '())))]
|
||||
[(< old-level n)
|
||||
(hash-set! level-ht old-level (remq tree (hash-ref level-ht old-level)))
|
||||
(hash-set! level-ht n (cons tree (hash-ref level-ht n '())))
|
||||
(hash-set! node-to-level-ht tree n)]
|
||||
[else
|
||||
(void)])
|
||||
(set! max-n (max n max-n))
|
||||
(for-each (λ (x) (loop x (+ n 1))) (send tree get-children))))
|
||||
|
||||
(let* ([tallest-column (apply max (hash-map level-ht (λ (x y) (length y))))]
|
||||
[canvas (get-canvas)]
|
||||
[_1 (send canvas min-client-height (* tallest-column dot-spacing))]
|
||||
[vertical-space
|
||||
(let-values ([(w h) (send canvas get-client-size)]) h)])
|
||||
(let loop ([n 0])
|
||||
(when (<= n max-n)
|
||||
(let ([nodes (reverse (hash-ref level-ht n))])
|
||||
(let loop ([nodes nodes]
|
||||
[y (/ (- vertical-space
|
||||
(* (length nodes) dot-spacing))
|
||||
2)])
|
||||
(cond
|
||||
[(null? nodes) (void)]
|
||||
[else
|
||||
(let* ([node (car nodes)]
|
||||
[dot-snip (send node get-dot-snip)])
|
||||
(insert dot-snip (* n dot-spacing) y) ;; in case the snip's been inserted already
|
||||
(move-to dot-snip (* n dot-spacing) y) ;; also do the move to
|
||||
(loop (cdr nodes) (+ y dot-spacing)))])))
|
||||
(loop (+ n 1)))))))
|
||||
(super-new)
|
||||
(inherit set-draw-arrow-heads?)
|
||||
(set-draw-arrow-heads? #f)))
|
||||
|
||||
(define (set-box/f b v) (when (box? b) (set-box! b v)))
|
||||
|
||||
(define dot-snip%
|
||||
(class (graph-snip-mixin snip%)
|
||||
(init-field node)
|
||||
|
||||
(inherit get-admin)
|
||||
(define color initial-color)
|
||||
(define/public (set-color c)
|
||||
(unless (equal? color c)
|
||||
(set! color c)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin needs-update this 0 0 dot-size dot-size)))))
|
||||
(define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb)
|
||||
(set-box/f wb dot-size)
|
||||
(set-box/f hb dot-size)
|
||||
(set-box/f descentb 0)
|
||||
(set-box/f spaceb 0)
|
||||
(set-box/f lspaceb 0)
|
||||
(set-box/f rspaceb 0))
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(let ([smoothing (send dc get-smoothing)]
|
||||
[brush (send dc get-brush)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(send dc set-brush color 'solid)
|
||||
(send dc draw-ellipse x y dot-size dot-size)
|
||||
(send dc set-brush brush)
|
||||
(send dc set-smoothing smoothing)))
|
||||
(define/override (on-event dc x y editorx editory evt)
|
||||
(when (send evt button-up?)
|
||||
(send node move-path)))
|
||||
|
||||
(define/override (copy) (new snip%))
|
||||
(super-new)
|
||||
(inherit set-snipclass set-flags get-flags)
|
||||
(set-flags (cons 'handles-events (get-flags)))
|
||||
(set-snipclass dot-snipclass)))
|
||||
|
||||
(define dot-snipclass
|
||||
(new
|
||||
(class snip-class%
|
||||
(define/override (read f)
|
||||
(new dot-snip%))
|
||||
(super-new))))
|
||||
(send dot-snipclass set-classname "plt-redex:dot")
|
||||
(send dot-snipclass set-version 1)
|
||||
(send (get-the-snip-class-list) add dot-snipclass)
|
||||
|
||||
|
||||
(define forward-size-editor-canvas%
|
||||
(class canvas:color%
|
||||
(inherit get-editor)
|
||||
(define/override (on-size w h)
|
||||
(send (get-editor) update-heights))
|
||||
(super-new)))
|
||||
|
||||
(define (mk-big-snip sexp node pp init-cw)
|
||||
(let* (#;[txt (new scheme:text%)]
|
||||
[txt (new text:keymap%)]
|
||||
[s (new big-snip%
|
||||
[pp pp]
|
||||
[node node]
|
||||
[editor txt]
|
||||
[expr sexp]
|
||||
[char-width init-cw])])
|
||||
(send txt set-autowrap-bitmap #f)
|
||||
#;(send txt freeze-colorer)
|
||||
(send s format-expr)
|
||||
s))
|
||||
|
||||
(define big-snip%
|
||||
(class size-editor-snip%
|
||||
(inherit get-editor)
|
||||
(init-field node)
|
||||
(define/public (get-node) node)
|
||||
(define clear-thunks '())
|
||||
(define/augment (on-width-changed w)
|
||||
(clear-diffs)
|
||||
(inner (void) on-width-changed w))
|
||||
(define/public (highlight-diffs to-color)
|
||||
(clear-diffs)
|
||||
(set! clear-thunks
|
||||
(map
|
||||
(λ (p) (send (get-editor) highlight-range
|
||||
(car p)
|
||||
(cdr p)
|
||||
(send the-color-database find-color "NavajoWhite")))
|
||||
to-color)))
|
||||
(define/public (clear-diffs)
|
||||
(for-each (λ (t) (t)) clear-thunks)
|
||||
(set! clear-thunks null))
|
||||
(super-new)))
|
||||
|
||||
(define columnar-pasteboard%
|
||||
(class (resizing-pasteboard-mixin pasteboard%)
|
||||
(init-field moved)
|
||||
|
||||
(define current-columns '())
|
||||
(inherit insert remove find-snip)
|
||||
|
||||
;; strange to think that this is the way to catch
|
||||
;; different snips becoming visible in the editor, but oh well.
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(let ([bx (box 0)]
|
||||
[by (box 0)]
|
||||
[bw (box 0)]
|
||||
[bh (box 0)])
|
||||
(send admin get-view bx by bw bh)
|
||||
(moved (unbox bx)
|
||||
(unbox by)
|
||||
(+ (unbox bx) (unbox bw))
|
||||
(+ (unbox by) (unbox bh))))))))
|
||||
|
||||
(define/public (change-columns orig-new-columns)
|
||||
(let loop ([current-columns current-columns]
|
||||
[new-columns orig-new-columns])
|
||||
(cond
|
||||
[(and (null? current-columns)
|
||||
(null? new-columns))
|
||||
(void)]
|
||||
[(null? new-columns)
|
||||
(insert/remove current-columns '())]
|
||||
[(null? current-columns)
|
||||
(insert/remove '() new-columns)]
|
||||
[(equal? (car current-columns)
|
||||
(car new-columns))
|
||||
(loop (cdr current-columns)
|
||||
(cdr new-columns))]
|
||||
[else
|
||||
(insert/remove current-columns new-columns)]))
|
||||
(set! current-columns orig-new-columns)
|
||||
(update-heights))
|
||||
|
||||
;; insert/remove : (listof (listof snip)) (listof (listof snip)) -> void
|
||||
(define/private (insert/remove to-remove to-insert)
|
||||
(let ([flat-to-remove (apply append to-remove)]
|
||||
[flat-to-insert (apply append to-insert)])
|
||||
(for-each
|
||||
(λ (x)
|
||||
(unless (memq x flat-to-insert)
|
||||
(remove x)))
|
||||
flat-to-remove)
|
||||
(for-each (λ (x) (insert x)) flat-to-insert)))
|
||||
|
||||
(inherit get-admin move-to resize)
|
||||
(define/public (update-heights)
|
||||
(let ([admin (get-admin)])
|
||||
(let-values ([(w h) (get-view-size)])
|
||||
(let loop ([columns current-columns]
|
||||
[x 0])
|
||||
(cond
|
||||
[(null? columns) (void)]
|
||||
[else
|
||||
(let* ([column (car columns)])
|
||||
(cond
|
||||
[(null? (cdr column))
|
||||
;; if there is only a single snip in the column, we let it be as long as it wants to be.
|
||||
(let* ([snip (car column)]
|
||||
[sw (get-snip-width snip)]
|
||||
[sh (get-snip-max-height snip)])
|
||||
(move-to snip x 0)
|
||||
(resize snip sw (max h sh))
|
||||
(loop (cdr columns) (+ x sw)))]
|
||||
[else
|
||||
;; otherwise, we make all of the snips fit into the visible area
|
||||
(let* ([base-space (quotient h (length column))]
|
||||
[widest
|
||||
(let loop ([snips column]
|
||||
[extra-space (modulo h (length column))]
|
||||
[y 0]
|
||||
[widest 0])
|
||||
(cond
|
||||
[(null? snips) widest]
|
||||
[else
|
||||
(let* ([snip (car snips)]
|
||||
[sw (get-snip-width snip)]
|
||||
[h (+ base-space
|
||||
(if (zero? extra-space)
|
||||
0
|
||||
1))])
|
||||
(move-to snip x y)
|
||||
(resize snip sw h)
|
||||
(loop (cdr snips)
|
||||
(if (zero? extra-space)
|
||||
0
|
||||
(- extra-space 1))
|
||||
(+ y h)
|
||||
(max widest sw)))]))])
|
||||
(loop (cdr columns)
|
||||
(+ x widest)))]))])))))
|
||||
|
||||
(inherit get-snip-location)
|
||||
(define/public (get-snip-width snip)
|
||||
(let ([lb (box 0)]
|
||||
[rb (box 0)])
|
||||
(get-snip-location snip lb #f #f)
|
||||
(get-snip-location snip rb #f #t)
|
||||
(- (unbox rb) (unbox lb))))
|
||||
|
||||
;; get-snip-max-height : snip -> number
|
||||
;; returns the maximum height that the snip wants to be
|
||||
;; (ie, the end position of the longest line)
|
||||
(define/private (get-snip-max-height snip)
|
||||
(let ([txt (send snip get-editor)]
|
||||
[yb (box 0)]
|
||||
[tb (box 0)]
|
||||
[bb (box 0)])
|
||||
(send snip get-margin (box 0) tb (box 0) bb)
|
||||
(send txt position-location (send txt last-position) #f yb #f #t #t)
|
||||
(+ (unbox yb)
|
||||
(unbox tb)
|
||||
(unbox bb))))
|
||||
|
||||
(define/private (get-view-size)
|
||||
(let ([admin (get-admin)])
|
||||
(if admin
|
||||
(let ([wb (box 0)]
|
||||
[hb (box 0)])
|
||||
(send admin get-view #f #f wb hb)
|
||||
(values (unbox wb) (- (unbox hb) 2)))
|
||||
(values 10 10))))
|
||||
|
||||
(super-new)))
|
||||
59
collects/redex/private/struct.ss
Normal file
59
collects/redex/private/struct.ss
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; don't provide reduction-relation directly, so that we can use that for the macro's name.
|
||||
(provide reduction-relation-lang
|
||||
reduction-relation-make-procs
|
||||
reduction-relation-rule-names
|
||||
reduction-relation-lws
|
||||
reduction-relation-procs
|
||||
build-reduction-relation
|
||||
reduction-relation?
|
||||
empty-reduction-relation
|
||||
make-rewrite-proc rewrite-proc? rewrite-proc-name
|
||||
(struct-out rule-pict))
|
||||
|
||||
(define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
|
||||
|
||||
;; type proc = (exp exp (any -> any) (listof any) -> (listof any)))
|
||||
;; a proc is a `cached' version of a make-proc, specialized to a particular langugage
|
||||
;; since that first application does all the work of compiling a pattern (wrt to a language),
|
||||
;; we want to avoid doing it multiple times, so it is cached in a reduction-relation struct
|
||||
|
||||
|
||||
(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name)
|
||||
(let ()
|
||||
(define-values (type constructor predicate accessor mutator)
|
||||
(make-struct-type 'rewrite-proc #f 2 0 #f '() #f 0))
|
||||
(values constructor
|
||||
predicate
|
||||
(make-struct-field-accessor accessor 1 'name))))
|
||||
|
||||
;; lang : compiled-language
|
||||
;; make-procs = (listof (compiled-lang -> proc))
|
||||
;; rule-names : (listof sym)
|
||||
;; procs : (listof proc)
|
||||
(define-struct reduction-relation (lang make-procs rule-names lws procs))
|
||||
|
||||
(define empty-reduction-relation (make-reduction-relation 'empty-reduction-relations-language
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
'()))
|
||||
|
||||
(define (build-reduction-relation orig-reduction-relation lang make-procs rule-names lws)
|
||||
(cond
|
||||
[orig-reduction-relation
|
||||
(let* ([new-names (map rewrite-proc-name make-procs)]
|
||||
[all-make-procs
|
||||
(append (filter (λ (x) (or (not (rewrite-proc-name x))
|
||||
(not (member (rewrite-proc-name x) new-names))))
|
||||
(reduction-relation-make-procs orig-reduction-relation))
|
||||
make-procs)])
|
||||
(make-reduction-relation lang
|
||||
all-make-procs
|
||||
(append (reduction-relation-rule-names orig-reduction-relation)
|
||||
rule-names)
|
||||
lws ;; only keep new lws for typesetting
|
||||
(map (λ (make-proc) (make-proc lang)) all-make-procs)))]
|
||||
[else
|
||||
(make-reduction-relation lang make-procs rule-names lws (map (λ (make-proc) (make-proc lang)) make-procs))]))
|
||||
125
collects/redex/private/subst-test.ss
Normal file
125
collects/redex/private/subst-test.ss
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
(module subst-test mzscheme
|
||||
(require "../subst.ss"
|
||||
(lib "match.ss"))
|
||||
|
||||
(define (lc-subst1 var val exp) (subst/proc var val exp lc-separate))
|
||||
(define (lc-free-vars exp) (free-vars/memoize (make-hash-table) exp lc-separate))
|
||||
(define (lc-rename old-name new-name exp) (alpha-rename old-name new-name exp lc-separate))
|
||||
|
||||
(define lc-subst2
|
||||
(subst
|
||||
[`(lambda ,vars ,body)
|
||||
(all-vars vars)
|
||||
(build (lambda (vars body) `(lambda ,vars ,body)))
|
||||
(subterm vars body)]
|
||||
[`(let (,l-var ,exp) ,body)
|
||||
(all-vars (list l-var))
|
||||
(build (lambda (l-vars exp body) `(let (,@l-vars ,exp) ,body)))
|
||||
(subterm '() exp)
|
||||
(subterm (list l-var) body)]
|
||||
[(? symbol?) (variable)]
|
||||
[(? number?) (constant)]
|
||||
[`(,fun ,@(args ...))
|
||||
(all-vars '())
|
||||
(build (lambda (vars fun . args) `(,fun ,@args)))
|
||||
(subterm '() fun)
|
||||
(subterms '() args)]))
|
||||
|
||||
(define (lc-separate exp constant variable combine sub-piece)
|
||||
(match exp
|
||||
[`(lambda ,vars ,body)
|
||||
(combine (lambda (vars body) `(lambda ,vars ,body))
|
||||
vars
|
||||
(sub-piece vars body))]
|
||||
[`(let (,l-var ,exp) ,body)
|
||||
(combine (lambda (l-vars exp body) `(let (,(car l-vars) ,exp) ,body))
|
||||
(list l-var)
|
||||
(sub-piece '() exp)
|
||||
(sub-piece (list l-var) body))]
|
||||
[(? symbol?) (variable (lambda (x) x) exp)]
|
||||
[(? number?) (constant exp)]
|
||||
[`(,fun ,@(args ...))
|
||||
(apply
|
||||
combine
|
||||
(lambda (variables fun . args) `(,fun ,@args))
|
||||
'()
|
||||
(append
|
||||
(list (sub-piece '() fun))
|
||||
(map (lambda (x) (sub-piece '() x)) args)))]))
|
||||
|
||||
(define test-cases 0)
|
||||
(define failed-tests? #f)
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test-exp expected)
|
||||
(syntax (test test-exp expected equal?))]
|
||||
[(_ test-exp expected same?)
|
||||
(syntax
|
||||
(let ([actual test-exp]
|
||||
[expected-v expected])
|
||||
;(printf "testing: ~s\n" (syntax-object->datum #'test-exp))
|
||||
(set! test-cases (+ test-cases 1))
|
||||
(unless (same? actual expected-v)
|
||||
(set! failed-tests? #t)
|
||||
(printf " test: ~s\n expected: ~s\n got: ~s\n"
|
||||
(syntax-object->datum #'test-exp)
|
||||
expected-v
|
||||
actual))))]))
|
||||
|
||||
(define (set-equal? xs ys)
|
||||
(and (andmap (lambda (x) (memq x ys)) xs)
|
||||
(andmap (lambda (y) (memq y xs)) ys)))
|
||||
|
||||
(define (lc-tests)
|
||||
(tests lc-free-vars lc-subst1 lc-rename)
|
||||
(tests #f lc-subst2 #f))
|
||||
|
||||
(define (tests free-vars subst rename)
|
||||
(when free-vars
|
||||
(test (free-vars 'x) '(x) set-equal?)
|
||||
(test (free-vars '(lambda (x) x)) '() set-equal?)
|
||||
(test (free-vars '(lambda (x) y)) '(y) set-equal?)
|
||||
(test (free-vars '(let (x 1) x)) '() set-equal?)
|
||||
(test (free-vars '(let (x 1) y)) '(y) set-equal?)
|
||||
(test (free-vars '(let (x x) y)) '(y x) set-equal?)
|
||||
(test (free-vars '(let (x 1) (y y))) '(y) set-equal?)
|
||||
(test (free-vars '(lambda (y) (y y))) '() set-equal?))
|
||||
|
||||
(when rename
|
||||
(test (rename 'x 'y 'x) 'x)
|
||||
(test (rename 'x 'y '(lambda (x) x)) '(lambda (y) y)))
|
||||
|
||||
(test (subst 'x 1 'x) 1)
|
||||
(test (subst 'x 1 'y) 'y)
|
||||
(test (subst 'x 1 '(lambda (x) x)) '(lambda (x) x))
|
||||
(test (subst 'x 1 '(lambda (y) x)) '(lambda (y) 1))
|
||||
(test (subst 'x 'y '(lambda (y) x)) '(lambda (y@) y))
|
||||
(test (subst 'x 'y '(lambda (y) (x y))) '(lambda (y@) (y y@)))
|
||||
(test (subst 'x 'y '(let (x 1) 1)) '(let (x 1) 1))
|
||||
(test (subst 'x 'y '(let (x 1) x)) '(let (x 1) x))
|
||||
(test (subst 'x 'y '(let (x 1) y)) '(let (x 1) y))
|
||||
(test (subst 'x 'y '(let (y 1) (x y))) '(let (y@ 1) (y y@)))
|
||||
(test (subst 'q '(lambda (x) y) '(lambda (y) y)) '(lambda (y) y))
|
||||
(test (subst 'q '(lambda (x) y) '(let ([y q]) y)) '(let ([y (lambda (x) y)]) y))
|
||||
(test (subst 'p '1 '(let (t 2) ((p t) t)))
|
||||
'(let (t 2) ((1 t) t)))
|
||||
(test (subst 'p '(lambda (s) s)
|
||||
'(let (t (lambda (s) s)) ((p t) t)))
|
||||
'(let (t (lambda (s) s)) (((lambda (s) s) t) t)))
|
||||
(test (subst 'p
|
||||
'(lambda (s) (s s))
|
||||
'(let (t (lambda (s) s))
|
||||
p))
|
||||
'(let (t (lambda (s) s))
|
||||
(lambda (s) (s s))))
|
||||
|
||||
(test (subst 's
|
||||
'(lambda (z) (s z))
|
||||
'(lambda (s) (lambda (z) (s z))))
|
||||
'(lambda (s) (lambda (z) (s z))))
|
||||
|
||||
(test (subst 's
|
||||
'(lambda (s) (lambda (z) (s z)))
|
||||
'(lambda (z) (s z)))
|
||||
'(lambda (z) ((lambda (s) (lambda (z) (s z))) z)))))
|
||||
10
collects/redex/private/term-fn.ss
Normal file
10
collects/redex/private/term-fn.ss
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
(module term-fn mzscheme
|
||||
(provide make-term-fn
|
||||
term-fn?
|
||||
term-fn-multi-arg?
|
||||
term-fn-get-id)
|
||||
|
||||
(define-values (struct-type make-term-fn term-fn? term-fn-get term-fn-set!)
|
||||
(make-struct-type 'term-fn #f 2 0))
|
||||
(define term-fn-get-id (make-struct-field-accessor term-fn-get 0))
|
||||
(define term-fn-multi-arg? (make-struct-field-accessor term-fn-get 1)))
|
||||
87
collects/redex/private/term-test.ss
Normal file
87
collects/redex/private/term-test.ss
Normal file
|
|
@ -0,0 +1,87 @@
|
|||
(module term-test mzscheme
|
||||
(require "term.ss"
|
||||
"matcher.ss"
|
||||
"test-util.ss")
|
||||
|
||||
(reset-count)
|
||||
(test (term 1) 1)
|
||||
(test (term (1 2)) (list 1 2))
|
||||
(test (term (1 ,(+ 1 1))) (list 1 2))
|
||||
(test (term-let ([x 1]) (term (x x))) (list 1 1))
|
||||
(test (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...))) '((y 1) (y 2) (y 3)))
|
||||
(test (term hole) (make-hole/intern none))
|
||||
(test (term (hole #f)) (make-hole/intern none))
|
||||
(test (term (hole hole-id)) (make-hole/intern 'hole-id))
|
||||
|
||||
(test (term (in-hole (1 hole) 2)) (term (1 2)))
|
||||
(test (term (in-hole (1 (hole #f)) 2)) (term (1 2)))
|
||||
(test (term (in-named-hole x (1 (hole x)) 2)) (term (1 2)))
|
||||
(test (term (in-named-hole x (1 hole (hole x)) 2)) (term (1 hole 2)))
|
||||
(test (term (in-hole (1 hole (hole x)) 2)) (term (1 2 (hole x))))
|
||||
|
||||
(test (equal? (term hole) (term hole)) #t)
|
||||
(test (equal? (term (hole x)) (term (hole x))) #t)
|
||||
(test (equal? (term (hole x)) (term (hole y))) #f)
|
||||
(test (hole? (term hole)) #t)
|
||||
(test (hole? (term (hole #f))) #t)
|
||||
(test (hole? (term (hole the-name))) #t)
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) q)))
|
||||
(term (f 1 2 3)))
|
||||
(term (1 2 3)))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term (f (zzzz))))
|
||||
(term (y (zzzz))))
|
||||
|
||||
(test (term-let-fn ((f (λ (x) (add1 (car x)))))
|
||||
(term (f 2)))
|
||||
(term 3))
|
||||
|
||||
(test (with-syntax ([((x ...) ...) (list (list 1 1) (list 2 2) (list 3 3))])
|
||||
(term-let-fn ((f (λ (x) (car x))))
|
||||
(term ((qq (f x) ...) ...))))
|
||||
(term ((qq 1 1) (qq 2 2) (qq 3 3))))
|
||||
|
||||
(test (term-let-fn ((f (lambda (x) (car x))))
|
||||
(term (f hole)))
|
||||
(term hole))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||
(term (g (f (zzzz))))))
|
||||
(term (ff (y (zzzz)))))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||
(term (f (g (f (zzzz)))))))
|
||||
(term (y (ff (y (zzzz))))))
|
||||
|
||||
(test (term-let ([x 1])
|
||||
(term (x . y)))
|
||||
(term (1 . y)))
|
||||
|
||||
(test (term-let ([(x ...) (list 3 2 1)])
|
||||
(term (x ... . y)))
|
||||
(term (3 2 1 . y)))
|
||||
|
||||
(test (term-let ([(x . y) (cons 1 2)])
|
||||
(term (x y)))
|
||||
(term (1 2)))
|
||||
|
||||
;; test that the implicit `plug' inserted by `in-hole'
|
||||
;; deals with ellipses properly
|
||||
(test (term-let ([(E ...) '(1 2 3)])
|
||||
(term ((in-hole E x) ...)))
|
||||
(term (1 2 3)))
|
||||
|
||||
(fprintf (current-error-port) "term-test.ss commented out test that fails; matches PR 8765\n")
|
||||
|
||||
#;
|
||||
(test (term-let-fn ((metafun (λ (x) x)))
|
||||
(term-let ((x 'whatever)
|
||||
((y ...) '(4 5 6)))
|
||||
(term (((metafun x) y) ...))))
|
||||
'((whatever 4) (whatever 5) (whatever 6)))
|
||||
|
||||
(print-tests-passed 'term-test.ss))
|
||||
146
collects/redex/private/term.ss
Normal file
146
collects/redex/private/term.ss
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
(module term mzscheme
|
||||
(require-for-syntax "term-fn.ss")
|
||||
(require "matcher.ss")
|
||||
|
||||
(provide term term-let term-let-fn term-define-fn)
|
||||
|
||||
(define (with-syntax* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ () e) (syntax e)]
|
||||
[(_ (a b ...) e) (syntax (with-syntax (a) (with-syntax* (b ...) e)))]))
|
||||
|
||||
(define-syntax (term stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg)
|
||||
#`(term-let-fn ((#,(datum->syntax-object stx 'in-hole)
|
||||
(λ (x)
|
||||
(unless (and (list? x)
|
||||
(= 2 (length x)))
|
||||
(error 'in-hole "expected two arguments, got ~s" x))
|
||||
(apply plug x))))
|
||||
(term/private arg))]))
|
||||
|
||||
(define-syntax (term/private orig-stx)
|
||||
(define outer-bindings '())
|
||||
|
||||
(define (rewrite stx)
|
||||
(let loop ([stx stx]
|
||||
[depth 0])
|
||||
(syntax-case stx (unquote unquote-splicing in-hole in-named-hole hole hole-here)
|
||||
[(f arg ...)
|
||||
(and (identifier? (syntax f))
|
||||
(term-fn? (syntax-local-value (syntax f) (λ () #f))))
|
||||
(let ([term-fn (syntax-local-value (syntax f) (λ () #f))])
|
||||
|
||||
(unless (term-fn-multi-arg? term-fn)
|
||||
(let ([arg-count (length (syntax->list #'(arg ...)))])
|
||||
(unless (= 1 arg-count)
|
||||
(raise-syntax-error 'term
|
||||
(format "single argument metafunction supplied with ~a arguments"
|
||||
arg-count)
|
||||
orig-stx
|
||||
stx))))
|
||||
(with-syntax ([f (term-fn-get-id term-fn)]
|
||||
[(f-results) (generate-temporaries '(f-results))])
|
||||
(let d-loop ([arg-dots (loop (syntax (arg ...)) depth)]
|
||||
[fres (syntax f-results)]
|
||||
[func (syntax (lambda (x) (f (syntax-object->datum x))))]
|
||||
[depth depth])
|
||||
(cond
|
||||
[(zero? depth)
|
||||
(let ([res
|
||||
(with-syntax ([fres fres]
|
||||
[func func]
|
||||
[arg-dots arg-dots])
|
||||
(set! outer-bindings (cons (syntax [fres (func (quasisyntax arg-dots))])
|
||||
outer-bindings))
|
||||
(syntax f-results))])
|
||||
res)]
|
||||
[else
|
||||
(with-syntax ([dots (quote-syntax ...)]
|
||||
[arg-dots arg-dots]
|
||||
[fres fres])
|
||||
(d-loop (syntax (arg-dots dots))
|
||||
(syntax (fres dots))
|
||||
(with-syntax ([f func])
|
||||
(syntax (lambda (l) (map f (syntax->list l)))))
|
||||
(- depth 1)))]))))]
|
||||
[f
|
||||
(and (identifier? (syntax f))
|
||||
(term-fn? (syntax-local-value (syntax f) (λ () #f))))
|
||||
(raise-syntax-error 'term "metafunction must be in an application" orig-stx stx)]
|
||||
[(unquote x)
|
||||
(syntax (unsyntax x))]
|
||||
[(unquote . x)
|
||||
(raise-syntax-error 'term "malformed unquote" orig-stx stx)]
|
||||
[(unquote-splicing x)
|
||||
(syntax (unsyntax-splicing x))]
|
||||
[(unquote-splicing . x)
|
||||
(raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
|
||||
[(in-hole id body)
|
||||
(syntax (unsyntax (plug (term id) (term body))))]
|
||||
[(in-hole . x)
|
||||
(raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
|
||||
[(in-named-hole name id body)
|
||||
(syntax (unsyntax (plug (term id) (term body) (or (term name) none))))]
|
||||
[(in-named-hole . x)
|
||||
(raise-syntax-error 'term "malformed in-named-hole" orig-stx stx)]
|
||||
[hole (syntax (unsyntax (make-hole/intern none)))]
|
||||
[(hole #f) (syntax (unsyntax (make-hole/intern none)))]
|
||||
[(hole stuff) (syntax (unsyntax (make-hole/intern 'stuff)))]
|
||||
[(x ...)
|
||||
(with-syntax ([(x-rewrite ...)
|
||||
(let i-loop ([xs (syntax->list (syntax (x ...)))])
|
||||
(cond
|
||||
[(null? xs) null]
|
||||
[(null? (cdr xs)) (list (loop (car xs) depth))]
|
||||
[(and (identifier? (cadr xs))
|
||||
(free-identifier=? (quote-syntax ...) (cadr xs)))
|
||||
(cons (loop (car xs) (+ depth 1))
|
||||
(i-loop (cdr xs)))]
|
||||
[else
|
||||
(cons (loop (car xs) depth)
|
||||
(i-loop (cdr xs)))]))])
|
||||
(syntax/loc stx (x-rewrite ...)))]
|
||||
[_ stx])))
|
||||
|
||||
(syntax-case orig-stx ()
|
||||
[(_ arg)
|
||||
(with-syntax ([rewritten (rewrite (syntax arg))])
|
||||
(let loop ([bs (reverse outer-bindings)])
|
||||
(cond
|
||||
[(null? bs) (syntax (syntax-object->datum (quasisyntax rewritten)))]
|
||||
[else (with-syntax ([rec (loop (cdr bs))]
|
||||
[fst (car bs)])
|
||||
(syntax (with-syntax (fst)
|
||||
rec)))])))]))
|
||||
|
||||
(define-syntax (term-let-fn stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([f rhs] ...) body1 body2 ...)
|
||||
(with-syntax ([(g ...) (generate-temporaries (syntax (f ...)))])
|
||||
(syntax
|
||||
(let ([g rhs] ...)
|
||||
(let-syntax ([f (make-term-fn #'g #t)] ...)
|
||||
body1
|
||||
body2 ...))))]))
|
||||
|
||||
(define-syntax (term-define-fn stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id exp multi-arg?)
|
||||
(with-syntax ([(id2) (generate-temporaries (syntax (id)))])
|
||||
(syntax
|
||||
(begin
|
||||
(define id2 exp)
|
||||
(define-syntax id
|
||||
(make-term-fn ((syntax-local-certifier) #'id2)
|
||||
multi-arg?)))))]))
|
||||
|
||||
(define-syntax (term-let stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([x rhs] ...) body1 body2 ...)
|
||||
(syntax
|
||||
(with-syntax ([x rhs] ...)
|
||||
(begin body1 body2 ...)))]
|
||||
[(_ x)
|
||||
(raise-syntax-error 'term-let "expected at least one body" stx)])))
|
||||
109
collects/redex/private/test-util.ss
Normal file
109
collects/redex/private/test-util.ss
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
#lang scheme
|
||||
|
||||
(require "matcher.ss")
|
||||
(provide test test-syn-err tests reset-count
|
||||
syn-err-test-namespace
|
||||
print-tests-passed
|
||||
equal/bindings?)
|
||||
|
||||
(define syn-err-test-namespace (make-base-namespace))
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(eval '(require "../reduction-semantics.ss")))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expected got)
|
||||
(with-syntax ([line (syntax-line (syntax got))]
|
||||
[fn (if (path? (syntax-source (syntax got)))
|
||||
(path->string (syntax-source (syntax got)))
|
||||
"<unknown file>")])
|
||||
(syntax/loc stx (test/proc (λ () expected) got line fn)))]))
|
||||
|
||||
(define-syntax (test-syn-err stx)
|
||||
(syntax-case stx ()
|
||||
[(_ exp regexp)
|
||||
(syntax/loc stx
|
||||
(test
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(with-handlers ((exn:fail:syntax? exn-message))
|
||||
(expand 'exp)
|
||||
'no-error-raised))
|
||||
regexp))]))
|
||||
|
||||
(define tests 0)
|
||||
(define failures 0)
|
||||
(define (reset-count) (set! tests 0))
|
||||
|
||||
(define (print-tests-passed filename)
|
||||
(cond
|
||||
[(= 0 failures)
|
||||
(printf "~a: all ~a tests passed.\n" filename tests)]
|
||||
[else
|
||||
(printf "~a: ~a test~a failed.\n" filename failures (if (= 1 failures) "" "s"))]))
|
||||
|
||||
(define (test/proc run expected line filename)
|
||||
;(printf "testing line ~s:~s\n" filename line)
|
||||
(let ([got (run)])
|
||||
(set! tests (+ tests 1))
|
||||
(unless (matches? got expected)
|
||||
(set! failures (+ 1 failures))
|
||||
(fprintf (current-error-port)
|
||||
"test/proc: file ~a line ~a:\n got ~s\nexpected ~s\n\n"
|
||||
filename
|
||||
line
|
||||
got
|
||||
expected))))
|
||||
|
||||
(define (matches? got expected)
|
||||
(cond
|
||||
[(regexp? expected)
|
||||
(and (string? got) (regexp-match expected got) #t)]
|
||||
[else
|
||||
(equal/bindings? got expected)]))
|
||||
|
||||
;; equal/bindings? : any any -> boolean
|
||||
;; compares two sexps (with embedded bindings) for equality.
|
||||
;; uses an order-insensitive comparison for the bindings
|
||||
(define (equal/bindings? fst snd)
|
||||
(let loop ([fst fst]
|
||||
[snd snd])
|
||||
(cond
|
||||
[(pair? fst)
|
||||
(and (pair? snd)
|
||||
(loop (car fst) (car snd))
|
||||
(loop (cdr fst) (cdr snd)))]
|
||||
[(mtch? fst)
|
||||
(and (mtch? snd)
|
||||
(loop (mtch-bindings fst)
|
||||
(mtch-bindings snd))
|
||||
(let ([g1 (gensym 'run-match-test-sym)])
|
||||
(equal/bindings? (mtch-context fst)
|
||||
(mtch-context snd)))
|
||||
(equal/bindings? (mtch-hole fst)
|
||||
(mtch-hole snd)))]
|
||||
[(bindings? fst)
|
||||
(and (bindings? snd)
|
||||
(let ([fst-table (bindings-table fst)]
|
||||
[snd-table (bindings-table snd)])
|
||||
(and (= (length fst-table)
|
||||
(length snd-table))
|
||||
(andmap
|
||||
loop
|
||||
(sort fst-table rib-lt)
|
||||
(sort snd-table rib-lt)))))]
|
||||
[(and (bind? fst)
|
||||
(bind? snd)
|
||||
(context? (bind-exp fst))
|
||||
(context? (bind-exp snd)))
|
||||
(and (equal? (bind-name fst) (bind-name snd))
|
||||
(let ([g (gensym 'run-match-test-sym2)])
|
||||
(equal/bindings? (bind-exp fst)
|
||||
(bind-exp snd))))]
|
||||
[(and (hole? fst)
|
||||
(hole? snd))
|
||||
(equal? (hole-name fst) (hole-name snd))]
|
||||
[else (equal? fst snd)])))
|
||||
|
||||
;; rib-lt : rib rib -> boolean
|
||||
(define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1))
|
||||
(format "~s" (bind-name r2))))
|
||||
990
collects/redex/private/tl-test.ss
Normal file
990
collects/redex/private/tl-test.ss
Normal file
|
|
@ -0,0 +1,990 @@
|
|||
(module tl-test mzscheme
|
||||
(require "../reduction-semantics.ss"
|
||||
"test-util.ss")
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;
|
||||
; ;
|
||||
; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;;
|
||||
; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ;
|
||||
; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
|
||||
; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;;
|
||||
; ; ;
|
||||
; ;;; ;;;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(define-language empty-language)
|
||||
|
||||
(define-language grammar
|
||||
(M (M M)
|
||||
number)
|
||||
(E hole
|
||||
(E M)
|
||||
(number E))
|
||||
(X (number any)
|
||||
(any number))
|
||||
(Q (Q ...)
|
||||
variable)
|
||||
(UN (add1 UN)
|
||||
zero))
|
||||
|
||||
(test (pair? (redex-match grammar M '(1 1))) #t)
|
||||
(test (pair? (redex-match grammar M '(1 1 1))) #f)
|
||||
(test (pair? (redex-match grammar
|
||||
(side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
|
||||
'(1 1)))
|
||||
#t)
|
||||
(test (pair? (redex-match grammar
|
||||
(side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
|
||||
'(1 2)))
|
||||
#f)
|
||||
|
||||
(test (pair? ((redex-match grammar M) '(1 1)))
|
||||
#t)
|
||||
|
||||
;; next 3: test naming of subscript-less non-terminals
|
||||
(test (pair? (redex-match grammar (M M) (term (1 1)))) #t)
|
||||
(test (pair? (redex-match grammar (M M) (term (1 2)))) #f)
|
||||
(test (pair? (redex-match grammar (M_1 M_2) (term (1 2)))) #t)
|
||||
|
||||
(define-language base-grammar
|
||||
(q 1)
|
||||
(e (+ e e) number)
|
||||
(x (variable-except +)))
|
||||
|
||||
(define-extended-language extended-grammar
|
||||
base-grammar
|
||||
(e .... (* e e))
|
||||
(x (variable-except + *))
|
||||
(r 2))
|
||||
|
||||
(test (pair? (redex-match extended-grammar e '(+ 1 1))) #t)
|
||||
(test (pair? (redex-match extended-grammar e '(* 2 2))) #t)
|
||||
(test (pair? (redex-match extended-grammar r '2)) #t)
|
||||
(test (pair? (redex-match extended-grammar q '1)) #t)
|
||||
(test (pair? (redex-match extended-grammar x '*)) #f)
|
||||
(test (pair? (redex-match extended-grammar x '+)) #f)
|
||||
(test (pair? (redex-match extended-grammar e '....)) #f)
|
||||
|
||||
;; make sure that `language' with a four period ellipses signals an error
|
||||
(test (regexp-match #rx"[.][.][.][.]" (with-handlers ([exn? exn-message])
|
||||
(let ()
|
||||
(define-language x (e ....))
|
||||
12)))
|
||||
'("...."))
|
||||
|
||||
|
||||
|
||||
;; test multiple variable non-terminals
|
||||
(let ()
|
||||
(define-language lang
|
||||
((l m) (l m) x)
|
||||
(x variable-not-otherwise-mentioned))
|
||||
(test (pair? (redex-match lang m (term x)))
|
||||
#t))
|
||||
|
||||
;; test multiple variable non-terminals
|
||||
(let ()
|
||||
(define-language lang
|
||||
((l m) (l m) x)
|
||||
(x variable-not-otherwise-mentioned))
|
||||
(test (pair? (redex-match lang l (term x)))
|
||||
#t))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
((x y) 1 2 3))
|
||||
(define-extended-language lang2 lang
|
||||
(x .... 4))
|
||||
(test (pair? (redex-match lang2 x 4)) #t)
|
||||
(test (pair? (redex-match lang2 y 4)) #t)
|
||||
(test (pair? (redex-match lang2 x 1)) #t)
|
||||
(test (pair? (redex-match lang2 y 2)) #t))
|
||||
|
||||
;; test that the variable "e" is not bound in the right-hand side of a side-condition
|
||||
;; this one signaled an error at some point
|
||||
(let ()
|
||||
(define-language bad
|
||||
(e 2 (side-condition (e) #t)))
|
||||
(test (pair? (redex-match bad e '(2)))
|
||||
#t))
|
||||
|
||||
;; test that the variable "e" is not bound in the right-hand side of a side-condition
|
||||
;; this one tests to make sure it really isn't bound
|
||||
(let ([x #f])
|
||||
(define-language bad
|
||||
(e 2 (side-condition (e) (set! x (term e)))))
|
||||
(redex-match bad e '(2))
|
||||
(test x 'e))
|
||||
|
||||
;; test multiple variable non-terminals being extended
|
||||
(let ()
|
||||
(define-language lang
|
||||
((x y) 1 2 3))
|
||||
(define-extended-language lang2 lang
|
||||
(x .... 4))
|
||||
(test (pair? (redex-match lang2 x 4)) #t)
|
||||
(test (pair? (redex-match lang2 y 4)) #t)
|
||||
(test (pair? (redex-match lang2 x 1)) #t)
|
||||
(test (pair? (redex-match lang2 y 2)) #t))
|
||||
|
||||
;; test multiple variable non-terminals in an extended language
|
||||
(let ()
|
||||
(define-language lang
|
||||
((x y) 1 2 3))
|
||||
(define-extended-language lang2 lang
|
||||
((z w) 5 6 7))
|
||||
(test (pair? (redex-match lang2 z 5)) #t)
|
||||
(test (pair? (redex-match lang2 w 6)) #t))
|
||||
|
||||
;; test cases that ensure that extending any one of a
|
||||
;; multiply defined non-terminal gets extended properly
|
||||
(let ()
|
||||
(define-language iswim
|
||||
((V U W) AA))
|
||||
|
||||
(define-extended-language iswim-cont
|
||||
iswim
|
||||
(W .... QQ))
|
||||
|
||||
(test (pair? (redex-match iswim-cont U (term QQ)))
|
||||
#t))
|
||||
|
||||
(let ()
|
||||
(define-language iswim
|
||||
((V U W) AA))
|
||||
|
||||
(define-extended-language iswim-cont
|
||||
iswim
|
||||
(W .... QQ))
|
||||
|
||||
(test (pair? (redex-match iswim-cont V (term QQ)))
|
||||
#t)
|
||||
(test (pair? (redex-match iswim-cont U (term QQ)))
|
||||
#t)
|
||||
(test (pair? (redex-match iswim-cont W (term QQ)))
|
||||
#t))
|
||||
|
||||
(let ()
|
||||
(define-language iswim
|
||||
((V U W) AA))
|
||||
|
||||
(define-extended-language iswim-cont
|
||||
iswim
|
||||
(V .... QQ))
|
||||
|
||||
(test (pair? (redex-match iswim-cont V (term QQ)))
|
||||
#t)
|
||||
(test (pair? (redex-match iswim-cont U (term QQ)))
|
||||
#t)
|
||||
(test (pair? (redex-match iswim-cont W (term QQ)))
|
||||
#t))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;;; ;
|
||||
; ; ; ;
|
||||
; ;;; ; ;;; ;;;;; ;;; ;;;;; ;; ;; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;
|
||||
; ; ; ; ;;;;; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;;;;; ;;;; ;;; ;;;;; ;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(define-metafunction f
|
||||
grammar
|
||||
[(side-condition (number_1 number_2)
|
||||
(< (term number_1)
|
||||
(term number_2)))
|
||||
x]
|
||||
[(number 1) y]
|
||||
[(number_1 2) ,(+ (term number_1) 2)]
|
||||
[(4 4) q]
|
||||
[(4 4) r])
|
||||
|
||||
(define-metafunction g
|
||||
grammar
|
||||
[X x])
|
||||
|
||||
(test (term (f (1 17))) 'x)
|
||||
(test (term (f (11 1))) 'y)
|
||||
(test (term (f (11 2))) 13)
|
||||
|
||||
|
||||
;; match two clauess => take first one
|
||||
(test (term (f (4 4))) 'q)
|
||||
|
||||
;; match one clause two ways => error
|
||||
(let ()
|
||||
(define-metafunction ll
|
||||
empty-language
|
||||
[(number_1 ... number_2 ...) 4])
|
||||
(test (with-handlers ((exn? (λ (x) 'exn-raised)))
|
||||
(term (ll ()))
|
||||
'no-exn)
|
||||
'no-exn)
|
||||
(test (with-handlers ((exn? (λ (x) 'exn-raised)))
|
||||
(term (ll (4 4)))
|
||||
'no-exn)
|
||||
'exn-raised))
|
||||
|
||||
;; match no ways => error
|
||||
(test (with-handlers ((exn? (λ (x) 'exn-raised))) (term (f mis-match)) 'no-exn)
|
||||
'exn-raised)
|
||||
|
||||
(define-metafunction h
|
||||
grammar
|
||||
[(M_1 M_2) ((h M_2) (h M_1))]
|
||||
[number_1 ,(+ (term number_1) 1)])
|
||||
|
||||
(test (term (h ((1 2) 3)))
|
||||
(term (4 (3 2))))
|
||||
|
||||
(define-metafunction h2
|
||||
grammar
|
||||
[(Q_1 ...) ((h2 Q_1) ...)]
|
||||
[variable z])
|
||||
|
||||
(test (term (h2 ((x y) a b c)))
|
||||
(term ((z z) z z z)))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f empty-language
|
||||
[(1) 1]
|
||||
[(2) 2]
|
||||
[3 3])
|
||||
(test (in-domain? (term 1) f) #f)
|
||||
(test (in-domain? (term (1)) f) #t)
|
||||
(test (in-domain? (term ((1))) f) #f)
|
||||
(test (in-domain? (term 3) f) #t)
|
||||
(test (in-domain? (term 4) f) #f))
|
||||
|
||||
(let ()
|
||||
(define-multi-args-metafunction f empty-language
|
||||
[(1) 1]
|
||||
[(2) 2]
|
||||
[(3 4) 3])
|
||||
(test (in-domain? (term 1) f) #f)
|
||||
(test (in-domain? (term (1)) f) #t)
|
||||
(test (in-domain? (term ((1))) f) #f)
|
||||
(test (in-domain? (term (3 4)) f) #t)
|
||||
(test (in-domain? (term 3) f) #f))
|
||||
|
||||
;; mutually recursive metafunctions
|
||||
(define-metafunction odd
|
||||
grammar
|
||||
[zero #f]
|
||||
[(add1 UN_1) (even UN_1)])
|
||||
|
||||
(define-metafunction even
|
||||
grammar
|
||||
[zero #t]
|
||||
[(add1 UN_1) (odd UN_1)])
|
||||
|
||||
(test (term (odd (add1 (add1 (add1 (add1 zero))))))
|
||||
(term #f))
|
||||
|
||||
(let ()
|
||||
(define-metafunction pRe
|
||||
empty-language
|
||||
[xxx 1])
|
||||
|
||||
(define-metafunction Merge-Exns
|
||||
empty-language
|
||||
[any_1 any_1])
|
||||
|
||||
(test (term (pRe (Merge-Exns xxx)))
|
||||
1))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f
|
||||
empty-language
|
||||
[(x) ,(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup)))]
|
||||
[y y]
|
||||
[var-should-be-lookedup var-should-be-lookedup]) ;; taking this case is bad!
|
||||
|
||||
(test (term (f (x))) (term y)))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f
|
||||
empty-language
|
||||
[(x) (x ,@(term-let ([var-should-be-lookedup 'y]) (term (f var-should-be-lookedup))) x)]
|
||||
[y (y)]
|
||||
[var-should-be-lookedup (var-should-be-lookedup)]) ;; taking this case is bad!
|
||||
|
||||
(test (term (f (x))) (term (x y x))))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f
|
||||
empty-language
|
||||
[(any_1 any_2)
|
||||
case1
|
||||
(side-condition (not (equal? (term any_1) (term any_2))))
|
||||
(side-condition (not (equal? (term any_1) 'x)))]
|
||||
[(any_1 any_2)
|
||||
case2
|
||||
(side-condition (not (equal? (term any_1) (term any_2))))]
|
||||
[(any_1 any_2)
|
||||
case3])
|
||||
(test (term (f (q r))) (term case1))
|
||||
(test (term (f (x y))) (term case2))
|
||||
(test (term (f (x x))) (term case3)))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f
|
||||
empty-language
|
||||
[(n number) (n number)]
|
||||
[(a any) (a any)]
|
||||
[(v variable) (v variable)]
|
||||
[(s string) (s string)])
|
||||
(test (term (f (n 1))) (term (n 1)))
|
||||
(test (term (f (a (#f "x" whatever)))) (term (a (#f "x" whatever))))
|
||||
(test (term (f (v x))) (term (v x)))
|
||||
(test (term (f (s "x"))) (term (s "x"))))
|
||||
|
||||
;; test ..._1 patterns
|
||||
(let ()
|
||||
(define-metafunction zip empty-language
|
||||
[((variable_id ..._1) (number_val ..._1))
|
||||
((variable_id number_val) ...)])
|
||||
|
||||
(test (term (zip ((a b) (1 2)))) (term ((a 1) (b 2)))))
|
||||
|
||||
(let ()
|
||||
(define-multi-args-metafunction f empty-language
|
||||
[(any_1 any_2 any_3) (any_3 any_2 any_1)])
|
||||
(test (term (f 1 2 3))
|
||||
(term (3 2 1))))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f empty-language
|
||||
[(any_1 any_2 any_3) 3])
|
||||
(define-metafunction/extension g empty-language f
|
||||
[(any_1 any_2) 2])
|
||||
(test (term (g (1 2))) 2)
|
||||
(test (term (g (1 2 3))) 3))
|
||||
|
||||
(let ()
|
||||
(define-multi-args-metafunction f empty-language
|
||||
[(any_1 any_2 any_3) 3])
|
||||
(define-multi-args-metafunction/extension g empty-language f
|
||||
[(any_1 any_2) 2])
|
||||
(test (term (g 1 2)) 2)
|
||||
(test (term (g 1 2 3)) 3))
|
||||
|
||||
(let ()
|
||||
(define-multi-args-metafunction f empty-language
|
||||
[(number_1 number_2) (f number_1)])
|
||||
(define-multi-args-metafunction/extension g empty-language f
|
||||
[(number_1) number_1])
|
||||
(define-multi-args-metafunction h empty-language
|
||||
[(number_1 number_2) (h number_1)]
|
||||
[(number_1) number_1])
|
||||
(test (term (g 11 17)) 11)
|
||||
(test (term (h 11 17)) 11))
|
||||
|
||||
(let ()
|
||||
(define-metafunction f empty-language
|
||||
[(number_1 number_2)
|
||||
number_3
|
||||
(where number_3 (+ (term number_1) (term number_2)))])
|
||||
(test (term (f (11 17))) 28))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; ;; ; ;; ;
|
||||
; ; ; ; ;
|
||||
; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;;
|
||||
; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ;; ;
|
||||
; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ;;;; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;;;; ;;;; ;;;;; ;; ;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;; ;;;; ;;;;; ;;;;; ;;; ;;;;; ;;; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (in-hole E_1 (number_1 number_2))
|
||||
(in-hole E_1 ,(* (term number_1) (term number_2)))))
|
||||
'((2 3) (4 5)))
|
||||
(list '(6 (4 5))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(~~> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2)))
|
||||
with
|
||||
[(--> (in-hole E_1 a) (in-hole E_1 b)) (~~> a b)])
|
||||
'((2 3) (4 5)))
|
||||
(list '(6 (4 5))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(==> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2)))
|
||||
with
|
||||
[(--> (M_1 a) (M_1 b)) (~~> a b)]
|
||||
[(~~> (M_1 a) (M_1 b)) (==> a b)])
|
||||
'((1 2) ((2 3) (4 5))))
|
||||
(list '((1 2) ((2 3) 20))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(~~> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2)))
|
||||
(==> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2)))
|
||||
with
|
||||
[(--> (M_1 a) (M_1 b)) (~~> a b)]
|
||||
[(--> (a M_1) (b M_1)) (==> a b)])
|
||||
'((2 3) (4 5)))
|
||||
(list '(6 (4 5))
|
||||
'((2 3) 20)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (M_1 (number_1 number_2))
|
||||
(M_1 ,(* (term number_1) (term number_2))))
|
||||
(==> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2)))
|
||||
with
|
||||
[(--> (a M_1) (b M_1)) (==> a b)])
|
||||
'((2 3) (4 5)))
|
||||
(list '((2 3) 20)
|
||||
'(6 (4 5))))
|
||||
|
||||
(test (apply-reduction-relation/tag-with-names
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mul))
|
||||
'(4 5))
|
||||
(list (list "mul" 20)))
|
||||
|
||||
(test (apply-reduction-relation/tag-with-names
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
"mul"))
|
||||
'(4 5))
|
||||
(list (list "mul" 20)))
|
||||
|
||||
(test (apply-reduction-relation/tag-with-names
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))))
|
||||
'(4 5))
|
||||
(list (list #f 20)))
|
||||
|
||||
(test (apply-reduction-relation/tag-with-names
|
||||
(reduction-relation
|
||||
grammar
|
||||
(==> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult)
|
||||
with
|
||||
[(--> (M_1 a) (M_1 b)) (==> a b)])
|
||||
'((2 3) (4 5)))
|
||||
(list (list "mult" '((2 3) 20))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(union-reduction-relations
|
||||
(reduction-relation empty-language
|
||||
(--> x a)
|
||||
(--> x b))
|
||||
(reduction-relation empty-language
|
||||
(--> x c)
|
||||
(--> x d)))
|
||||
'x)
|
||||
(list 'a 'b 'c 'd))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(union-reduction-relations
|
||||
(reduction-relation empty-language (--> x a))
|
||||
(reduction-relation empty-language (--> x b))
|
||||
(reduction-relation empty-language (--> x c))
|
||||
(reduction-relation empty-language (--> x d)))
|
||||
'x)
|
||||
(list 'a 'b 'c 'd))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> (number_1 number_2)
|
||||
number_2
|
||||
(side-condition (< (term number_1) (term number_2))))
|
||||
(--> (number_1 number_2)
|
||||
number_1
|
||||
(side-condition (< (term number_2) (term number_1)))))
|
||||
'(1 2))
|
||||
(list 2))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> x #f))
|
||||
(term x))
|
||||
(list #f))
|
||||
|
||||
(define-language x-language
|
||||
(x variable))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
x-language
|
||||
(--> x (x x)))
|
||||
'y)
|
||||
(list '(y y)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
x-language
|
||||
(--> (x ...) ((x ...))))
|
||||
'(p q r))
|
||||
(list '((p q r))))
|
||||
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(eval (quote-syntax
|
||||
(define-language grammar
|
||||
(M (M M)
|
||||
number)
|
||||
(E hole
|
||||
(E M)
|
||||
(number E))
|
||||
(X (number any)
|
||||
(any number))
|
||||
(Q (Q ...)
|
||||
variable)
|
||||
(UN (add1 UN)
|
||||
zero)))))
|
||||
|
||||
(test-syn-err (reduction-relation
|
||||
grammar
|
||||
(~~> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2)))
|
||||
with
|
||||
[(--> (M a) (M b)) (~~> a b)]
|
||||
[(~~> (M a) (M b)) (==> a b)])
|
||||
#rx"no rules")
|
||||
|
||||
(test-syn-err (reduction-relation grammar)
|
||||
#rx"no rules use -->")
|
||||
|
||||
(test-syn-err (reduction-relation
|
||||
grammar
|
||||
(~~> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))))
|
||||
#rx"~~> relation is not defined")
|
||||
|
||||
(test-syn-err (reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult)
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult))
|
||||
#rx"same name on multiple rules")
|
||||
|
||||
(test-syn-err (reduction-relation
|
||||
grammar
|
||||
(--> 1 2)
|
||||
(==> 3 4))
|
||||
#rx"not defined.*==>")
|
||||
|
||||
(test-syn-err (reduction-relation
|
||||
empty-language
|
||||
(--> 1 2)
|
||||
(==> 3 4)
|
||||
with
|
||||
[(~> a b) (==> a b)])
|
||||
#rx"not defined.*~>")
|
||||
|
||||
(test-syn-err (define-language bad-lang1 (e name)) #rx"name")
|
||||
(test-syn-err (define-language bad-lang2 (name x)) #rx"name")
|
||||
(test-syn-err (define-language bad-lang3 (x_y x)) #rx"x_y")
|
||||
|
||||
;; expect union with duplicate names to fail
|
||||
(test (with-handlers ((exn? (λ (x) 'passed)))
|
||||
(union-reduction-relations
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult))
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult)))
|
||||
'failed)
|
||||
'passed)
|
||||
|
||||
(test (with-handlers ((exn? (λ (x) 'passed)))
|
||||
(union-reduction-relations
|
||||
(union-reduction-relations
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult))
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult3)))
|
||||
|
||||
(union-reduction-relations
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult))
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult2))))
|
||||
'passed)
|
||||
'passed)
|
||||
|
||||
;; sorting in this test case is so that the results come out in a predictable manner.
|
||||
(test (sort
|
||||
(apply-reduction-relation
|
||||
(compatible-closure
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult))
|
||||
grammar
|
||||
M)
|
||||
'((2 3) (4 5)))
|
||||
(λ (x y) (string<=? (format "~s" x) (format "~s" y))))
|
||||
(list '((2 3) 20)
|
||||
'(6 (4 5))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(compatible-closure
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (number_1 number_2)
|
||||
,(* (term number_1) (term number_2))
|
||||
mult))
|
||||
grammar
|
||||
M)
|
||||
'(4 2))
|
||||
(list '8))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(context-closure
|
||||
(context-closure
|
||||
(reduction-relation grammar (--> 1 2))
|
||||
grammar
|
||||
(y hole))
|
||||
grammar
|
||||
(x hole))
|
||||
'(x (y 1)))
|
||||
(list '(x (y 2))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(--> (variable_1 variable_2)
|
||||
(variable_1 variable_2 x)
|
||||
mul
|
||||
(fresh x)))
|
||||
'(x x1))
|
||||
(list '(x x1 x2)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
grammar
|
||||
(~~> number
|
||||
x
|
||||
(fresh x))
|
||||
with
|
||||
[(--> (variable_1 variable_2 a) (variable_1 variable_2 b)) (~~> a b)])
|
||||
'(x x1 2))
|
||||
(list '(x x1 x2)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
x-language
|
||||
(--> (x_1 ...)
|
||||
(x ...)
|
||||
(fresh ((x ...) (x_1 ...)))))
|
||||
'(x y x1))
|
||||
(list '(x2 x3 x4)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> (variable_1 ...)
|
||||
(x ... variable_1 ...)
|
||||
(fresh ((x ...) (variable_1 ...) (variable_1 ...)))))
|
||||
'(x y z))
|
||||
(list '(x1 y1 z1 x y z)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> variable_1
|
||||
(x variable_1)
|
||||
(fresh (x variable_1))))
|
||||
'q)
|
||||
(list '(q1 q)))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(extend-reduction-relation (reduction-relation empty-language (--> 1 2))
|
||||
empty-language
|
||||
(--> 1 3))
|
||||
1)
|
||||
'(3 2))
|
||||
|
||||
(let ()
|
||||
(define-language e1
|
||||
(e 1))
|
||||
(define-language e2
|
||||
(e 2))
|
||||
(define red1 (reduction-relation e1 (--> e (e e))))
|
||||
(define red2 (extend-reduction-relation red1 e2 (--> ignoreme ignoreme)))
|
||||
(test (apply-reduction-relation red1 1) '((1 1)))
|
||||
(test (apply-reduction-relation red1 2) '())
|
||||
(test (apply-reduction-relation red2 1) '())
|
||||
(test (apply-reduction-relation red2 2) '((2 2))))
|
||||
|
||||
(let ()
|
||||
(define red1 (reduction-relation empty-language
|
||||
(--> a (a a)
|
||||
a)
|
||||
(--> b (b b)
|
||||
b)
|
||||
(--> q x)))
|
||||
(define red2 (extend-reduction-relation red1
|
||||
empty-language
|
||||
(--> a (c c)
|
||||
a)
|
||||
(--> q z)))
|
||||
(test (apply-reduction-relation red1 (term a)) (list (term (a a))))
|
||||
(test (apply-reduction-relation red1 (term b)) (list (term (b b))))
|
||||
(test (apply-reduction-relation red1 (term q)) (list (term x)))
|
||||
(test (apply-reduction-relation red2 (term a)) (list (term (c c))))
|
||||
(test (apply-reduction-relation red2 (term b)) (list (term (b b))))
|
||||
(test (apply-reduction-relation red2 (term q)) (list (term z) (term x))))
|
||||
|
||||
(let ()
|
||||
(define red1
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(==> a (a a)
|
||||
a)
|
||||
(==> b (b b)
|
||||
b)
|
||||
(==> q w)
|
||||
with
|
||||
[(--> (X a) (X b)) (==> a b)]))
|
||||
|
||||
(define red2
|
||||
(extend-reduction-relation
|
||||
red1
|
||||
empty-language
|
||||
(==> a (c c)
|
||||
a)
|
||||
(==> q z)
|
||||
with
|
||||
[(--> (X a) (X b)) (==> a b)]))
|
||||
|
||||
(test (apply-reduction-relation red1 (term (X a))) (list (term (X (a a)))))
|
||||
(test (apply-reduction-relation red1 (term (X b))) (list (term (X (b b)))))
|
||||
(test (apply-reduction-relation red1 (term (X q))) (list (term (X w))))
|
||||
(test (apply-reduction-relation red2 (term (X a))) (list (term (X (c c)))))
|
||||
(test (apply-reduction-relation red2 (term (X b))) (list (term (X (b b)))))
|
||||
(test (apply-reduction-relation red2 (term (X q))) (list (term (X z))
|
||||
(term (X w)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; examples from doc.txt
|
||||
;;
|
||||
|
||||
(define-language lc-lang
|
||||
(e (e e ...)
|
||||
x
|
||||
v)
|
||||
(c (v ... c e ...)
|
||||
hole)
|
||||
(v (lambda (x ...) e))
|
||||
(x variable-not-otherwise-mentioned))
|
||||
|
||||
(test (let ([m (redex-match lc-lang e (term (lambda (x) x)))])
|
||||
(and m (length m)))
|
||||
1)
|
||||
|
||||
(define-extended-language qabc-lang lc-lang (q a b c))
|
||||
|
||||
(test (redex-match qabc-lang
|
||||
e
|
||||
(term (lambda (a) a)))
|
||||
#f)
|
||||
|
||||
(test (let ([m (redex-match qabc-lang
|
||||
e
|
||||
(term (lambda (z) z)))])
|
||||
(and m (length m)))
|
||||
1)
|
||||
|
||||
(require (lib "list.ss"))
|
||||
;; free-vars : e -> (listof x)
|
||||
(define-metafunction free-vars
|
||||
lc-lang
|
||||
[(e_1 e_2 ...)
|
||||
,(apply append (term ((free-vars e_1) (free-vars e_2) ...)))]
|
||||
[x_1 ,(list (term x_1))]
|
||||
[(lambda (x_1 ...) e_1)
|
||||
,(foldr remq (term (free-vars e_1)) (term (x_1 ...)))])
|
||||
|
||||
(test (term (free-vars (lambda (x) (x y))))
|
||||
(list 'y))
|
||||
|
||||
(test (variable-not-in (term (x y z)) 'x)
|
||||
(term x1))
|
||||
|
||||
(test (variable-not-in (term (y z)) 'x)
|
||||
(term x))
|
||||
(test (variable-not-in (term (x x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) 'x)
|
||||
(term x11))
|
||||
(test (variable-not-in (term (x x11)) 'x)
|
||||
(term x1))
|
||||
(test (variable-not-in (term (x x1 x2 x3)) 'x1)
|
||||
(term x4))
|
||||
(test (variable-not-in (term (x x1 x1 x2 x2)) 'x)
|
||||
(term x3))
|
||||
|
||||
(test (variables-not-in (term (x y z)) '(x))
|
||||
'(x1))
|
||||
(test (variables-not-in (term (x2 y z)) '(x x x))
|
||||
'(x x1 x3))
|
||||
|
||||
(test ((term-match/single empty-language
|
||||
[(variable_x variable_y)
|
||||
(cons (term variable_x)
|
||||
(term variable_y))])
|
||||
'(x y))
|
||||
'(x . y))
|
||||
|
||||
(test ((term-match/single empty-language
|
||||
[(side-condition (variable_x variable_y)
|
||||
(eq? (term variable_x) 'x))
|
||||
(cons (term variable_x)
|
||||
(term variable_y))])
|
||||
'(x y))
|
||||
'(x . y))
|
||||
|
||||
(define-language x-is-1-language
|
||||
[x 1])
|
||||
|
||||
(test ((term-match/single x-is-1-language
|
||||
[(x x)
|
||||
1])
|
||||
'(1 1))
|
||||
1)
|
||||
|
||||
(test (let ([x 0])
|
||||
(cons ((term-match empty-language
|
||||
[(any_a ... number_1 any_b ...)
|
||||
(begin (set! x (+ x 1))
|
||||
(term number_1))])
|
||||
'(1 2 3))
|
||||
x))
|
||||
'((3 2 1) . 3))
|
||||
|
||||
(test ((term-match empty-language
|
||||
[number_1
|
||||
(term number_1)]
|
||||
[number_1
|
||||
(term number_1)])
|
||||
'1)
|
||||
'(1 1))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation
|
||||
x-language
|
||||
(--> (x_one x_!_one x_!_one x_!_one)
|
||||
(x_one x_!_one)))
|
||||
(term (a a b c)))
|
||||
(list (term (a x_!_one))))
|
||||
|
||||
;; tests `where' clauses in reduction relation
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation empty-language
|
||||
(--> number_1
|
||||
y
|
||||
(where y ,(+ 1 (term number_1)))))
|
||||
3)
|
||||
'(4))
|
||||
|
||||
;; tests `where' clauses scoping
|
||||
(test (let ([x 5])
|
||||
(apply-reduction-relation
|
||||
(reduction-relation empty-language
|
||||
(--> any
|
||||
z
|
||||
(where y ,x)
|
||||
(where x 2)
|
||||
(where z ,(+ (term y) (term x)))))
|
||||
'whatever))
|
||||
'(7))
|
||||
|
||||
;; test that where clauses bind in side-conditions that follow
|
||||
(let ([save1 #f]
|
||||
[save2 #f])
|
||||
(term-let ([y (term outer-y)])
|
||||
(test (begin (apply-reduction-relation
|
||||
(reduction-relation empty-language
|
||||
(--> number_1
|
||||
y
|
||||
(side-condition (set! save1 (term y)))
|
||||
(where y inner-y)
|
||||
(side-condition (set! save2 (term y)))))
|
||||
3)
|
||||
(list save1 save2))
|
||||
(list 'outer-y 'inner-y))))
|
||||
|
||||
(test (apply-reduction-relation
|
||||
(reduction-relation empty-language
|
||||
(--> any
|
||||
y
|
||||
(fresh x)
|
||||
(where y x)))
|
||||
'x)
|
||||
'(x1))
|
||||
|
||||
(print-tests-passed 'tl-test.ss))
|
||||
614
collects/redex/private/traces.ss
Normal file
614
collects/redex/private/traces.ss
Normal file
|
|
@ -0,0 +1,614 @@
|
|||
;; should cache the count of new snips -- dont
|
||||
;; use `count-snips'; use something associated with the
|
||||
;; equal hash-table
|
||||
|
||||
#lang scheme
|
||||
|
||||
(require mrlib/graph
|
||||
"reduction-semantics.ss"
|
||||
"matcher.ss"
|
||||
"size-snip.ss"
|
||||
"dot.ss"
|
||||
scheme/gui/base
|
||||
framework)
|
||||
|
||||
(preferences:set-default 'plt-reducer:show-bottom #t boolean?)
|
||||
|
||||
(define dark-pen-color (make-parameter "blue"))
|
||||
(define light-pen-color (make-parameter "lightblue"))
|
||||
(define dark-brush-color (make-parameter "lightblue"))
|
||||
(define light-brush-color (make-parameter "white"))
|
||||
(define dark-text-color (make-parameter "blue"))
|
||||
(define light-text-color (make-parameter "lightblue"))
|
||||
|
||||
;; after (about) this many steps, stop automatic, initial reductions
|
||||
(define reduction-steps-cutoff (make-parameter 20))
|
||||
|
||||
(define-struct term-node (snip))
|
||||
(define (term-node-parents term-node) (send (term-node-snip term-node) get-one-step-parents))
|
||||
(define (term-node-children term-node) (send (term-node-snip term-node) get-one-step-children))
|
||||
(define (term-node-expr term-node) (send (term-node-snip term-node) get-expr))
|
||||
(define (term-node-labels term-node) (send (term-node-snip term-node) get-one-step-labels))
|
||||
(define (term-node-set-color! term-node r?)
|
||||
(let loop ([snip (term-node-snip term-node)])
|
||||
(parameterize ([current-eventspace (send snip get-my-eventspace)])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(send (term-node-snip term-node) set-bad r?))))))
|
||||
|
||||
(define (term-node-set-red! term-node r?)
|
||||
(term-node-set-color! term-node (and r? "pink")))
|
||||
|
||||
(define initial-font-size
|
||||
(make-parameter
|
||||
(send (send (send (editor:get-standard-style-list)
|
||||
find-named-style
|
||||
"Standard")
|
||||
get-font)
|
||||
get-point-size)))
|
||||
|
||||
;; the initial spacing between row and columns of the reduction terms
|
||||
(define x-spacing 15)
|
||||
(define y-spacing 15)
|
||||
|
||||
(define (traces reductions pre-exprs #:multiple? [multiple? #f] #:pred [pred (λ (x) #t)] #:pp [pp default-pretty-printer] #:colors [colors '()])
|
||||
(define exprs (if multiple? pre-exprs (list pre-exprs)))
|
||||
(define main-eventspace (current-eventspace))
|
||||
(define saved-parameterization (current-parameterization))
|
||||
(define graph-pb (new graph-pasteboard% [shrink-down? #t]))
|
||||
(define f (instantiate red-sem-frame% ()
|
||||
(label "PLT Redex Reduction Graph")
|
||||
(style '(toolbar-button))
|
||||
(graph-pb graph-pb)
|
||||
(width 600)
|
||||
(height 400)
|
||||
(toggle-panel-callback
|
||||
(lambda ()
|
||||
(send remove-my-contents-panel
|
||||
change-children
|
||||
(lambda (l)
|
||||
(preferences:set 'plt-reducer:show-bottom (null? l))
|
||||
(if (null? l)
|
||||
(list bottom-panel)
|
||||
null)))))))
|
||||
(define ec (make-object editor-canvas% (send f get-area-container) graph-pb))
|
||||
(define remove-my-contents-panel (new vertical-panel%
|
||||
(parent (send f get-area-container))
|
||||
(stretchable-height #f)))
|
||||
(define bottom-panel (new vertical-panel%
|
||||
(parent remove-my-contents-panel)
|
||||
(stretchable-height #f)))
|
||||
(define font-size (instantiate slider% ()
|
||||
(label "Font Size")
|
||||
(min-value 1)
|
||||
(init-value (initial-font-size))
|
||||
(max-value 127)
|
||||
(parent bottom-panel)
|
||||
(callback (lambda (slider evt) (set-font-size (send slider get-value))))))
|
||||
(define lower-panel (instantiate horizontal-panel% ()
|
||||
(parent bottom-panel)
|
||||
(stretchable-height #f)))
|
||||
(define dot-panel (instantiate horizontal-panel% ()
|
||||
(parent bottom-panel)
|
||||
(stretchable-height #f)))
|
||||
(define reduce-button (make-object button%
|
||||
"Reducing..."
|
||||
lower-panel
|
||||
(lambda (x y)
|
||||
(reduce-button-callback))))
|
||||
(define status-message (instantiate message% ()
|
||||
(label "")
|
||||
(parent lower-panel)
|
||||
(stretchable-width #t)))
|
||||
(define dot (new button%
|
||||
[parent dot-panel]
|
||||
[label "Fix Layout"]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(set! dot? (not dot?))
|
||||
(dot-callback))]))
|
||||
(define dot-mode (new choice%
|
||||
[parent dot-panel]
|
||||
[label #f]
|
||||
[callback
|
||||
(λ x
|
||||
(send dot-overlap set-label
|
||||
(if (equal? 0 (send dot-mode get-selection))
|
||||
"Top to Bottom"
|
||||
"No Overlap"))
|
||||
(when dot?
|
||||
(dot-callback)))]
|
||||
[choices (list dot-label neato-label neato-hier-label neato-ipsep-label)]))
|
||||
(define dot-overlap (new check-box%
|
||||
[value #t]
|
||||
[callback
|
||||
(λ x
|
||||
(when dot?
|
||||
(dot-callback)))]
|
||||
[parent dot-panel]
|
||||
[label "Top to Bottom"]))
|
||||
|
||||
(define snip-cache (make-hash))
|
||||
|
||||
;; call-on-eventspace-main-thread : (-> any) -> any
|
||||
;; =reduction thread=
|
||||
(define (call-on-eventspace-main-thread thnk)
|
||||
(parameterize ([current-eventspace main-eventspace])
|
||||
(let ([s (make-semaphore 0)]
|
||||
[ans #f])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(call-with-parameterization
|
||||
saved-parameterization
|
||||
(λ ()
|
||||
(set! ans (thnk))))
|
||||
(semaphore-post s)))
|
||||
(semaphore-wait s)
|
||||
ans)))
|
||||
|
||||
;; only changed on the reduction thread
|
||||
;; frontier : (listof (is-a?/c graph-editor-snip%))
|
||||
(define frontier
|
||||
(map (lambda (expr) (build-snip snip-cache #f expr pred pp
|
||||
(dark-pen-color) (light-pen-color)
|
||||
(dark-text-color) (light-text-color) #f))
|
||||
exprs))
|
||||
|
||||
;; set-font-size : number -> void
|
||||
;; =eventspace main thread=
|
||||
(define (set-font-size size)
|
||||
(let* ([scheme-standard (send (editor:get-standard-style-list) find-named-style
|
||||
"Standard")]
|
||||
[scheme-delta (make-object style-delta%)])
|
||||
(send scheme-standard get-delta scheme-delta)
|
||||
(send scheme-delta set-size-mult 0)
|
||||
(send scheme-delta set-size-add size)
|
||||
(send scheme-standard set-delta scheme-delta)
|
||||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip shrink-down))
|
||||
(loop (send snip next))))))
|
||||
|
||||
;; color-spec-list->color-scheme : (list (union string? #f)^4) -> (list string?^4)
|
||||
;; converts a list of user-specified colors (including false) into a list of color strings, filling in
|
||||
;; falses with the default colors
|
||||
(define (color-spec-list->color-scheme l)
|
||||
(map (λ (c d) (or c d))
|
||||
l
|
||||
(list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))
|
||||
|
||||
|
||||
(define name->color-ht
|
||||
(let ((ht (make-hash)))
|
||||
(for-each
|
||||
(λ (c)
|
||||
(hash-set! ht (car c)
|
||||
(color-spec-list->color-scheme
|
||||
(match (cdr c)
|
||||
[`(,color)
|
||||
(list color color (dark-text-color) (light-text-color))]
|
||||
[`(,dark-arrow-color ,light-arrow-color)
|
||||
(list dark-arrow-color light-arrow-color (dark-text-color) (light-text-color))]
|
||||
[`(,dark-arrow-color ,light-arrow-color ,text-color)
|
||||
(list dark-arrow-color light-arrow-color text-color text-color)]
|
||||
[`(,_ ,_ ,_ ,_)
|
||||
(cdr c)]))))
|
||||
colors)
|
||||
ht))
|
||||
|
||||
;; red->colors : string -> (values string string string string)
|
||||
(define (red->colors reduction-name)
|
||||
(apply values (hash-ref name->color-ht
|
||||
reduction-name
|
||||
(λ () (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))))
|
||||
|
||||
;; reduce-frontier : -> void
|
||||
;; =reduction thread=
|
||||
;; updates frontier with the new snip after a single reduction
|
||||
(define (reduce-frontier)
|
||||
(let ([col #f])
|
||||
(let loop ([snips frontier]
|
||||
[new-frontier null]
|
||||
[y 0])
|
||||
(cond
|
||||
[(null? snips)
|
||||
(set! frontier new-frontier)]
|
||||
[else
|
||||
(let* ([snip (car snips)]
|
||||
[new-snips
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map (lambda (red+sexp)
|
||||
(let-values ([(name sexp) (apply values red+sexp)])
|
||||
(call-on-eventspace-main-thread
|
||||
(λ ()
|
||||
(let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color)
|
||||
(red->colors name)])
|
||||
(build-snip snip-cache snip sexp pred pp
|
||||
light-arrow-color dark-arrow-color dark-label-color light-label-color
|
||||
name))))))
|
||||
(apply-reduction-relation/tag-with-names reductions (send snip get-expr))))]
|
||||
[new-y
|
||||
(call-on-eventspace-main-thread
|
||||
(lambda () ; =eventspace main thread=
|
||||
(send graph-pb begin-edit-sequence)
|
||||
(unless col ;; only compute col here, incase user moves snips
|
||||
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
|
||||
(begin0
|
||||
(insert-into col y graph-pb new-snips)
|
||||
(send graph-pb end-edit-sequence)
|
||||
(send status-message set-label
|
||||
(string-append (term-count (count-snips)) "...")))))])
|
||||
(loop (cdr snips)
|
||||
(append new-frontier new-snips)
|
||||
new-y))]))))
|
||||
|
||||
;; count-snips : -> number
|
||||
;; =eventspace main thread=
|
||||
;; counts the snips in `pb'.
|
||||
(define (count-snips)
|
||||
(let loop ([n 0]
|
||||
[snip (send graph-pb find-first-snip)])
|
||||
(cond
|
||||
[snip (loop (+ n 1) (send snip next))]
|
||||
[else n])))
|
||||
|
||||
;; dot-callback : -> void
|
||||
(define dot? #f)
|
||||
(define (dot-callback)
|
||||
(cond
|
||||
[(not (find-dot))
|
||||
(message-box "PLT Redex"
|
||||
"Could not find the dot binary")]
|
||||
[dot?
|
||||
(dot-positioning graph-pb
|
||||
(send dot-mode get-string-selection)
|
||||
(not (send dot-overlap get-value))) ;; refreshes the display
|
||||
(send graph-pb immobilize)
|
||||
(send dot set-label "Unlock")
|
||||
(send reduce-button enable #f)
|
||||
(send font-size enable #f)]
|
||||
[else
|
||||
(send graph-pb mobilize)
|
||||
(send graph-pb set-dot-callback #f)
|
||||
(send graph-pb invalidate-bitmap-cache)
|
||||
(send dot set-label "Fix Layout")
|
||||
(send reduce-button enable #t)
|
||||
(send font-size enable #t)]))
|
||||
|
||||
;; reduce-button-callback : -> void
|
||||
;; =eventspace main thread=
|
||||
(define (reduce-button-callback)
|
||||
(send reduce-button enable #f)
|
||||
(send reduce-button set-label "Reducing...")
|
||||
(thread
|
||||
(lambda ()
|
||||
(do-some-reductions)
|
||||
(queue-callback
|
||||
(lambda () ;; =eventspace main thread=
|
||||
(scroll-to-rightmost-snip)
|
||||
(send reduce-button set-label "Reduce")
|
||||
(cond
|
||||
[(null? frontier)
|
||||
(send status-message set-label (term-count (count-snips)))]
|
||||
[else
|
||||
(send status-message set-label
|
||||
(string-append (term-count (count-snips))
|
||||
"(possibly more to find)"))
|
||||
(send reduce-button enable #t)]))))))
|
||||
|
||||
(define (term-count n)
|
||||
(format "found ~a term~a" n (if (equal? n 1) "" "s")))
|
||||
|
||||
;; do-some-reductions : -> void
|
||||
;; =reduction thread=
|
||||
;; reduces some number of times,
|
||||
;; adding at least reduction-steps-cutoff steps
|
||||
;; before stopping (unless there aren't that many left)
|
||||
(define (do-some-reductions)
|
||||
(let ([initial-size (call-on-eventspace-main-thread count-snips)])
|
||||
(let loop ()
|
||||
(cond
|
||||
[(null? frontier) (void)]
|
||||
[((call-on-eventspace-main-thread count-snips) . >= . (+ initial-size (reduction-steps-cutoff)))
|
||||
(void)]
|
||||
[else
|
||||
(reduce-frontier)
|
||||
(loop)]))))
|
||||
|
||||
;; scroll-to-rightmost-snip : -> void
|
||||
;; =eventspace main thread=
|
||||
(define (scroll-to-rightmost-snip)
|
||||
(let ([rightmost-snip (send graph-pb find-first-snip)])
|
||||
(let loop ([rightmost-snip rightmost-snip]
|
||||
[rightmost-y (get-right-edge rightmost-snip)]
|
||||
[snip (send rightmost-snip next)])
|
||||
(cond
|
||||
[(not snip) (make-snip-visible rightmost-snip)]
|
||||
[else
|
||||
(let ([snip-y (get-right-edge snip)])
|
||||
(if (<= rightmost-y snip-y)
|
||||
(loop snip snip-y (send snip next))
|
||||
(loop rightmost-snip rightmost-y (send snip next))))]))))
|
||||
|
||||
;; make-snip-visisble : snip -> void
|
||||
;; =eventspace-main-thread=
|
||||
(define (make-snip-visible snip)
|
||||
(let ([bl (box 0)]
|
||||
[bt (box 0)]
|
||||
[br (box 0)]
|
||||
[bb (box 0)])
|
||||
(send graph-pb get-snip-location snip bl bt #f)
|
||||
(send graph-pb get-snip-location snip br bb #t)
|
||||
(send graph-pb scroll-to
|
||||
snip
|
||||
0
|
||||
0
|
||||
(- (unbox br) (unbox bl))
|
||||
(- (unbox bb) (unbox bt))
|
||||
#t)))
|
||||
|
||||
;; get-right-edge : snip -> void
|
||||
;; =eventspace-main-thread=
|
||||
(define (get-right-edge snip)
|
||||
(let ([br (box 0)])
|
||||
(send graph-pb get-snip-location snip br #f #t)
|
||||
(unbox br)))
|
||||
|
||||
(send remove-my-contents-panel
|
||||
change-children
|
||||
(lambda (l)
|
||||
(if (preferences:get 'plt-reducer:show-bottom)
|
||||
(list bottom-panel)
|
||||
null)))
|
||||
(dot-callback) ;; make sure the state is initialized right
|
||||
(insert-into init-rightmost-x 0 graph-pb frontier)
|
||||
(set-font-size (initial-font-size))
|
||||
(reduce-button-callback)
|
||||
(send f show #t))
|
||||
|
||||
(define red-sem-frame%
|
||||
(class (frame:standard-menus-mixin (frame:basic-mixin frame%))
|
||||
(init-field graph-pb toggle-panel-callback)
|
||||
(define/override (file-menu:create-save?) #f)
|
||||
(define/override (on-toolbar-button-click) (toggle-panel-callback))
|
||||
(define/override (file-menu:between-save-as-and-print file-menu)
|
||||
(make-object menu-item% "Print..."
|
||||
file-menu
|
||||
(lambda (item evt) (send graph-pb print)))
|
||||
(make-object menu-item% "Export as Encapsulted PostScript..."
|
||||
file-menu
|
||||
(lambda (item evt) (send graph-pb print #t #f 'postscript this #f)))
|
||||
(make-object menu-item% "Export as PostScript..."
|
||||
file-menu
|
||||
(lambda (item evt) (send graph-pb print #t #f 'postscript this)))
|
||||
(make-object menu-item%
|
||||
"Toggle bottom stuff"
|
||||
file-menu
|
||||
(lambda (item evt) (toggle-panel-callback))))
|
||||
(super-new)))
|
||||
|
||||
(define graph-pasteboard%
|
||||
(class (resizing-pasteboard-mixin
|
||||
(graph-pasteboard-mixin pasteboard%))
|
||||
(define dot-callback #f)
|
||||
(define/public (set-dot-callback cb) (set! dot-callback cb))
|
||||
(define/override (draw-edges dc left top right bottom dx dy)
|
||||
(if dot-callback
|
||||
(dot-callback this dc left top right bottom dx dy)
|
||||
(super draw-edges dc left top right bottom dx dy)))
|
||||
|
||||
(define mobile? #t)
|
||||
(define/public (immobilize) (set! mobile? #f))
|
||||
(define/public (mobilize) (set! mobile? #t))
|
||||
|
||||
(define/augment (can-interactive-move? evt) mobile?)
|
||||
(define/augment (can-interactive-resize? evt) mobile?)
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define graph-editor-snip%
|
||||
(class* (graph-snip-mixin size-editor-snip%) (reflowing-snip<%>)
|
||||
(init-field my-eventspace)
|
||||
(inherit get-expr)
|
||||
(define bad-color #f)
|
||||
(inherit get-admin)
|
||||
(define/public (get-my-eventspace) my-eventspace)
|
||||
(define/public (set-bad color)
|
||||
(send (get-editor) set-bad color)
|
||||
(set! bad-color color)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(let ([wb (box 0)]
|
||||
[hb (box 0)])
|
||||
(send admin get-view-size wb hb)
|
||||
(send admin needs-update this 0 0 (unbox wb) (unbox hb))))))
|
||||
|
||||
(define names-to-here '())
|
||||
;; might have the same parent twice with a different name
|
||||
;; might have different parens with the same name.
|
||||
;; just record this in a list.
|
||||
(define/public (record-edge-label parent name)
|
||||
(set! names-to-here (cons (list parent name) names-to-here)))
|
||||
(define/public (get-one-step-labels)
|
||||
(map cadr names-to-here))
|
||||
(define/public (get-one-step-parents) (map (λ (x) (send (car x) get-term-node)) names-to-here))
|
||||
(define term-node #f)
|
||||
(define/public (get-term-node)
|
||||
(unless term-node
|
||||
(set! term-node (make-term-node this)))
|
||||
term-node)
|
||||
|
||||
(inherit get-children)
|
||||
(define/public (get-one-step-children)
|
||||
(map (λ (x) (send x get-term-node)) (get-children)))
|
||||
|
||||
(inherit get-editor)
|
||||
(inherit get-extent)
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(when bad-color
|
||||
(let ([bw (box 0)]
|
||||
[bh (box 0)]
|
||||
[pen (send dc get-pen)]
|
||||
[brush (send dc get-brush)])
|
||||
(get-extent dc x y bw bh #f #f #f #f)
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen bad-color 1 'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush bad-color 'solid))
|
||||
(send dc draw-rectangle x y (unbox bw) (unbox bh))
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)))
|
||||
(super draw dc x y left top right bottom dx dy draw-caret))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define program-text%
|
||||
(class scheme:text%
|
||||
(define bad-color #f)
|
||||
(define/public (set-bad color) (set! bad-color color))
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(when (and bad-color before?)
|
||||
(let ([pen (send dc get-pen)]
|
||||
[brush (send dc get-brush)])
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen bad-color 1 'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush bad-color 'solid))
|
||||
(send dc draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top))
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)))
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret))
|
||||
(super-new)))
|
||||
|
||||
(define lines-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
|
||||
;; where the first snips are inserted
|
||||
(define init-rightmost-x 25)
|
||||
|
||||
;; insert-into : number number pasteboard (listof snip%) -> number
|
||||
;; inserts the snips into the pasteboard vertically
|
||||
;; aligned, starting at (x,y). Returns
|
||||
;; the y coordinate where another snip might be inserted.
|
||||
(define (insert-into x y pb exprs)
|
||||
(let loop ([exprs exprs]
|
||||
[y y])
|
||||
(cond
|
||||
[(null? exprs) y]
|
||||
[else
|
||||
(let ([es (car exprs)])
|
||||
(send pb insert es x y)
|
||||
(loop (cdr exprs)
|
||||
(+ y (find-snip-height pb es) y-spacing)))])))
|
||||
|
||||
;; build-snip : hash-table
|
||||
;; (union #f (is-a?/c graph-snip<%>))
|
||||
;; sexp
|
||||
;; sexp -> boolean
|
||||
;; (any port number -> void)
|
||||
;; color
|
||||
;; (union #f string)
|
||||
;; -> (union #f (is-a?/c graph-editor-snip%))
|
||||
;; returns #f if a snip corresponding to the expr has already been created.
|
||||
;; also adds in the links to the parent snip
|
||||
;; =eventspace main thread=
|
||||
(define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name)
|
||||
(let-values ([(snip new?)
|
||||
(let/ec k
|
||||
(k
|
||||
(hash-ref
|
||||
cache
|
||||
expr
|
||||
(lambda ()
|
||||
(let ([new-snip (make-snip parent-snip expr pred pp)])
|
||||
(hash-set! cache expr new-snip)
|
||||
(k new-snip #t))))
|
||||
#f))])
|
||||
|
||||
(when parent-snip
|
||||
(send snip record-edge-label parent-snip name)
|
||||
(add-links/text-colors parent-snip snip
|
||||
(send the-pen-list find-or-create-pen dark-arrow-color 0 'solid)
|
||||
(send the-pen-list find-or-create-pen light-arrow-color 0 'solid)
|
||||
(send the-brush-list find-or-create-brush (dark-brush-color) 'solid)
|
||||
(send the-brush-list find-or-create-brush (light-brush-color) 'solid)
|
||||
(make-object color% dark-label-color)
|
||||
(make-object color% light-label-color)
|
||||
0 0
|
||||
name)
|
||||
(update-badness pred parent-snip (send parent-snip get-expr)))
|
||||
|
||||
(update-badness pred snip expr)
|
||||
|
||||
(and new? snip)))
|
||||
|
||||
(define (update-badness pred snip expr)
|
||||
(let ([good?
|
||||
(if (procedure-arity-includes? pred 2)
|
||||
(pred expr (send snip get-term-node))
|
||||
(pred expr))])
|
||||
(send snip set-bad (cond
|
||||
[(or (string? good?)
|
||||
(is-a? good? color%))
|
||||
good?]
|
||||
[(not good?) "pink"]
|
||||
[else #f]))))
|
||||
|
||||
;; make-snip : (union #f (is-a?/c graph-snip<%>))
|
||||
;; sexp
|
||||
;; sexp -> boolean
|
||||
;; (any port number -> void)
|
||||
;; -> (is-a?/c graph-editor-snip%)
|
||||
;; unconditionally creates a new graph-editor-snip
|
||||
;; =eventspace main thread=
|
||||
(define (make-snip parent-snip expr pred pp)
|
||||
(let* ([text (new program-text%)]
|
||||
[es (instantiate graph-editor-snip% ()
|
||||
(char-width (initial-char-width))
|
||||
(editor text)
|
||||
(my-eventspace (current-eventspace))
|
||||
(pp pp)
|
||||
(expr expr))])
|
||||
(send text set-autowrap-bitmap #f)
|
||||
(send text freeze-colorer)
|
||||
(send es format-expr)
|
||||
es))
|
||||
|
||||
;; find-rightmost-x : pasteboard -> number
|
||||
(define (find-rightmost-x pb)
|
||||
(let ([first-snip (send pb find-first-snip)])
|
||||
(if first-snip
|
||||
(let loop ([snip first-snip]
|
||||
[max-x (find-snip-right-edge pb first-snip)])
|
||||
(cond
|
||||
[snip
|
||||
(loop (send snip next)
|
||||
(max max-x (find-snip-right-edge pb snip)))]
|
||||
[else max-x]))
|
||||
init-rightmost-x)))
|
||||
|
||||
;; find-snip-right-edge : editor snip -> number
|
||||
(define (find-snip-right-edge ed snip)
|
||||
(let ([br (box 0)])
|
||||
(send ed get-snip-location snip br #f #t)
|
||||
(unbox br)))
|
||||
|
||||
;; find-snip-height : editor snip -> number
|
||||
(define (find-snip-height ed snip)
|
||||
(let ([bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(send ed get-snip-location snip #f bt #f)
|
||||
(send ed get-snip-location snip #f bb #t)
|
||||
(- (unbox bb)
|
||||
(unbox bt))))
|
||||
|
||||
(provide traces
|
||||
term-node?
|
||||
term-node-parents
|
||||
term-node-children
|
||||
term-node-labels
|
||||
term-node-set-red!
|
||||
term-node-set-color!
|
||||
term-node-expr)
|
||||
|
||||
(provide reduction-steps-cutoff initial-font-size
|
||||
dark-pen-color light-pen-color dark-brush-color light-brush-color
|
||||
dark-text-color light-text-color)
|
||||
3
collects/redex/private/underscore-allowed.ss
Normal file
3
collects/redex/private/underscore-allowed.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(module underscore-allowed mzscheme
|
||||
(provide underscore-allowed)
|
||||
(define underscore-allowed '(any number string variable)))
|
||||
65
collects/redex/reduction-semantics.ss
Normal file
65
collects/redex/reduction-semantics.ss
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract)
|
||||
|
||||
(require "private/reduction-semantics.ss"
|
||||
"private/matcher.ss"
|
||||
"private/term.ss"
|
||||
"private/rg.ss"
|
||||
"private/loc-wrapper.ss")
|
||||
|
||||
(provide (all-from-out "private/rg.ss"))
|
||||
|
||||
(provide reduction-relation
|
||||
--> fresh with ;; keywords for reduction-relation
|
||||
extend-reduction-relation
|
||||
reduction-relation?
|
||||
|
||||
compatible-closure
|
||||
context-closure
|
||||
|
||||
define-language
|
||||
define-extended-language
|
||||
plug
|
||||
compiled-lang?
|
||||
term
|
||||
term-let
|
||||
none?
|
||||
define-metafunction
|
||||
define-metafunction/extension
|
||||
define-multi-args-metafunction
|
||||
define-multi-args-metafunction/extension
|
||||
metafunction
|
||||
in-domain?)
|
||||
|
||||
(provide (rename-out [test-match redex-match])
|
||||
term-match
|
||||
term-match/single
|
||||
match? match-bindings
|
||||
make-bind bind? bind-name bind-exp
|
||||
|
||||
test-equal
|
||||
test-->
|
||||
test-predicate
|
||||
test-results)
|
||||
|
||||
(provide to-lw
|
||||
(struct-out lw))
|
||||
|
||||
(provide/contract
|
||||
[reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
|
||||
[language-nts (-> compiled-lang? (listof symbol?))]
|
||||
[set-cache-size! (-> number? void?)]
|
||||
[apply-reduction-relation (-> reduction-relation? any/c (listof any/c))]
|
||||
[apply-reduction-relation/tag-with-names
|
||||
(-> reduction-relation? any/c (listof (list/c (or/c false/c string?) any/c)))]
|
||||
[apply-reduction-relation* (-> reduction-relation? any/c (listof any/c))]
|
||||
[union-reduction-relations (->* (reduction-relation? reduction-relation?)
|
||||
()
|
||||
#:rest (listof reduction-relation?)
|
||||
reduction-relation?)]
|
||||
|
||||
[lookup-binding (case->
|
||||
(-> bindings? symbol? any)
|
||||
(-> bindings? symbol? (-> any) any))]
|
||||
[variable-not-in (any/c symbol? . -> . symbol?)]
|
||||
[variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))])
|
||||
43
collects/redex/schemeunit.ss
Normal file
43
collects/redex/schemeunit.ss
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
#lang scheme
|
||||
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(except-in "reduction-semantics.ss" check))
|
||||
|
||||
(provide test-reduces
|
||||
check-reduces
|
||||
test-reduces/multiple
|
||||
check-reduces/multiple)
|
||||
|
||||
(define-shortcut (test-reduces reds from to) (check-reduces reds from to))
|
||||
|
||||
(define-check (check-reduces reds from to)
|
||||
(let ([all (apply-reduction-relation* reds from)])
|
||||
(cond
|
||||
[(null? (cdr all))
|
||||
(unless (equal? (car all) to)
|
||||
(with-check-info
|
||||
(('expected to)
|
||||
('actual (car all)))
|
||||
(fail-check)))]
|
||||
[else
|
||||
(with-check-info
|
||||
(('multiple-results all))
|
||||
(fail-check))])))
|
||||
|
||||
(define-shortcut (test-reduces/multiple reds from to) (check-reduces/multiple reds from to))
|
||||
|
||||
(define-check (check-reduces/multiple reds from to)
|
||||
(let ([all (apply-reduction-relation* reds from)])
|
||||
(unless (set-equal? all to)
|
||||
(with-check-info
|
||||
(('expecteds to)
|
||||
('actuals all))
|
||||
(fail-check)))))
|
||||
|
||||
(define (set-equal? s1 s2)
|
||||
(define (subset? a b)
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (λ (x) (hash-set! ht x #t)) a)
|
||||
(andmap (λ (x) (hash-ref ht x #f)) b)))
|
||||
(and (subset? s1 s2)
|
||||
(subset? s2 s1)))
|
||||
292
collects/redex/subst.ss
Normal file
292
collects/redex/subst.ss
Normal file
|
|
@ -0,0 +1,292 @@
|
|||
(module subst mzscheme
|
||||
(require (lib "match.ss")
|
||||
(prefix plt: (lib "plt-match.ss"))
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide plt-subst subst
|
||||
all-vars variable subterm subterms constant build
|
||||
subst/proc alpha-rename free-vars/memoize)
|
||||
|
||||
(define-syntax (all-vars stx) (raise-syntax-error 'subst "all-vars out of context" stx))
|
||||
(define-syntax (variable stx) (raise-syntax-error 'subst "variable out of context" stx))
|
||||
(define-syntax (subterm stx) (raise-syntax-error 'subst "subterm out of context" stx))
|
||||
(define-syntax (subterms stx) (raise-syntax-error 'subst "subterms out of context" stx))
|
||||
(define-syntax (constant stx) (raise-syntax-error 'subst "constant out of context" stx))
|
||||
(define-syntax (build stx) (raise-syntax-error 'subst "build out of context" stx))
|
||||
|
||||
(define-syntax (make-subst stx)
|
||||
(syntax-case stx ()
|
||||
[(_ subst match)
|
||||
(syntax
|
||||
(define-syntax (subst stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (pat rhs (... ...)) (... ...))
|
||||
(with-syntax ([term/arg #'term/arg]
|
||||
[constant/arg #'constant/arg]
|
||||
[variable/arg #'variable/arg]
|
||||
[combine/arg #'combine/arg]
|
||||
[sub-piece/arg #'subpiece/arg])
|
||||
(define (handle-rhs rhs-stx)
|
||||
(syntax-case rhs-stx (all-vars build subterm subterms variable constant)
|
||||
[((all-vars all-vars-exp) (build build-exp) sub-pieces (... ...))
|
||||
(with-syntax ([(sub-pieces (... ...))
|
||||
(map (lambda (subterm-stx)
|
||||
(syntax-case subterm-stx (subterm subterms)
|
||||
[(subterm vars body) (syntax (list (sub-piece/arg vars body)))]
|
||||
[(subterms vars terms)
|
||||
(syntax
|
||||
(let ([terms-var terms])
|
||||
(unless (list? terms-var)
|
||||
(error 'subst
|
||||
"expected a list of terms for `subterms' subclause, got: ~e"
|
||||
terms-var))
|
||||
(map (lambda (x) (sub-piece/arg vars x))
|
||||
terms-var)))]
|
||||
[else (raise-syntax-error
|
||||
'subst
|
||||
"unknown all-vars subterm"
|
||||
stx
|
||||
subterm-stx)]))
|
||||
(syntax->list (syntax (sub-pieces (... ...)))))])
|
||||
(syntax
|
||||
(apply combine/arg
|
||||
build-exp
|
||||
all-vars-exp
|
||||
(append sub-pieces (... ...)))))]
|
||||
[((all-vars) sub-pieces (... ...))
|
||||
(raise-syntax-error 'subst "expected all-vars must have an argument" stx rhs-stx)]
|
||||
[((all-vars all-vars-exp) not-build-clause anything (... ...))
|
||||
(raise-syntax-error 'subst "expected build clause" (syntax not-build-clause))]
|
||||
[((all-vars all-vars-exp))
|
||||
(raise-syntax-error 'subst "missing build clause" (syntax (all-vars all-vars-exp)))]
|
||||
[((constant))
|
||||
(syntax (constant/arg term/arg))]
|
||||
[((variable))
|
||||
(syntax (variable/arg (lambda (x) x) term/arg))]
|
||||
[(unk unk-more (... ...))
|
||||
(raise-syntax-error 'subst "unknown clause" (syntax unk))]))
|
||||
(with-syntax ([(expanded-rhs (... ...))
|
||||
(map handle-rhs (syntax->list (syntax ((rhs (... ...)) (... ...)))))])
|
||||
(syntax
|
||||
(let ([separate
|
||||
(lambda (term/arg constant/arg variable/arg combine/arg sub-piece/arg)
|
||||
(match term/arg
|
||||
[pat expanded-rhs] (... ...)
|
||||
[else (error 'subst "no matching clauses for ~s\n" term/arg)]))])
|
||||
(lambda (var val exp)
|
||||
(subst/proc var val exp separate))))))])))]))
|
||||
|
||||
(make-subst subst match)
|
||||
(make-subst plt-subst plt:match)
|
||||
|
||||
(define (subst/proc var val exp separate)
|
||||
(let* ([free-vars-cache (make-hash-table 'equal)]
|
||||
[fv-val (free-vars/memoize free-vars-cache val separate)])
|
||||
(let loop ([exp exp])
|
||||
(let ([fv-exp (free-vars/memoize free-vars-cache exp separate)]
|
||||
[handle-constant
|
||||
(lambda (x) x)]
|
||||
[handle-variable
|
||||
(lambda (rebuild var-name)
|
||||
(if (equal? var-name var)
|
||||
val
|
||||
(rebuild var-name)))]
|
||||
[handle-complex
|
||||
(lambda (maker vars . subpieces)
|
||||
(cond
|
||||
[(ormap (lambda (var) (memq var fv-val)) vars)
|
||||
=>
|
||||
(lambda (to-be-renamed-l)
|
||||
(let ([to-be-renamed (car to-be-renamed-l)])
|
||||
(loop
|
||||
(alpha-rename
|
||||
to-be-renamed
|
||||
(pick-new-name to-be-renamed (cons to-be-renamed fv-val))
|
||||
exp
|
||||
separate))))]
|
||||
[else
|
||||
(apply maker
|
||||
vars
|
||||
(map (lambda (subpiece)
|
||||
(let ([sub-term-binders (subpiece-binders subpiece)]
|
||||
[sub-term (subpiece-term subpiece)])
|
||||
(if (memq var sub-term-binders)
|
||||
sub-term
|
||||
(loop sub-term))))
|
||||
subpieces))]))])
|
||||
(if (member var fv-exp)
|
||||
(separate
|
||||
exp
|
||||
handle-constant
|
||||
handle-variable
|
||||
handle-complex
|
||||
make-subpiece)
|
||||
exp)))))
|
||||
|
||||
(define-struct subpiece (binders term) (make-inspector))
|
||||
|
||||
;; alpha-rename : symbol symbol term separate -> term
|
||||
;; renames the occurrences of to-be-renamed that are
|
||||
;; bound in the "first level" of exp.
|
||||
(define (alpha-rename to-be-renamed new-name exp separate)
|
||||
(define (first exp)
|
||||
(separate exp
|
||||
first-handle-constant
|
||||
first-handle-variable
|
||||
first-handle-complex
|
||||
first-handle-complex-subpiece))
|
||||
(define (first-handle-constant x) x)
|
||||
(define (first-handle-variable rebuild var) (rebuild var))
|
||||
(define (first-handle-complex maker vars . subpieces)
|
||||
(let ([replaced-vars
|
||||
(map (lambda (x) (if (eq? x to-be-renamed) new-name x))
|
||||
vars)])
|
||||
(apply maker replaced-vars subpieces)))
|
||||
(define (first-handle-complex-subpiece binders subterm)
|
||||
(if (memq to-be-renamed binders)
|
||||
(beyond-first subterm)
|
||||
subterm))
|
||||
|
||||
(define (beyond-first exp)
|
||||
(define (handle-constant x) x)
|
||||
(define (handle-variable rebuild var)
|
||||
(if (eq? var to-be-renamed)
|
||||
(rebuild new-name)
|
||||
(rebuild var)))
|
||||
(define (handle-complex maker vars . subpieces)
|
||||
(apply maker vars subpieces))
|
||||
(define (handle-complex-subpiece binders subterm)
|
||||
(if (memq to-be-renamed binders)
|
||||
subterm
|
||||
(beyond-first subterm)))
|
||||
(separate
|
||||
exp
|
||||
handle-constant
|
||||
handle-variable
|
||||
handle-complex
|
||||
handle-complex-subpiece))
|
||||
|
||||
(first exp))
|
||||
|
||||
;; free-vars/memoize : hash-table[sexp -o> (listof symbols)] sexp separate -> (listof symbols)
|
||||
;; doesn't cache against separate -- if it changes, a new hash-table must be passed in,
|
||||
;; or the caching will be wrong
|
||||
(define (free-vars/memoize cache exp separate)
|
||||
(hash-table-get
|
||||
cache
|
||||
exp
|
||||
(lambda ()
|
||||
(let ([res (free-vars/compute cache exp separate)])
|
||||
(hash-table-put! cache exp res)
|
||||
res))))
|
||||
|
||||
;; free-vars/memoize : hash-table[sexp -o> (listof symbols)] sexp separate -> (listof symbols)
|
||||
(define (free-vars/compute cache exp separate)
|
||||
(let ([handle-constant (lambda (x) '())]
|
||||
[handle-variable (lambda (rebuild var) (list var))]
|
||||
[handle-complex
|
||||
(lambda (maker vars . subpieces)
|
||||
(apply append subpieces))]
|
||||
[handle-complex-subpiece
|
||||
(lambda (binders subterm)
|
||||
(foldl remove-all
|
||||
(free-vars/memoize cache subterm separate)
|
||||
binders))])
|
||||
(separate
|
||||
exp
|
||||
handle-constant
|
||||
handle-variable
|
||||
handle-complex
|
||||
handle-complex-subpiece)))
|
||||
|
||||
(define (remove-all var lst)
|
||||
(let loop ([lst lst]
|
||||
[ans '()])
|
||||
(cond
|
||||
[(null? lst) ans]
|
||||
[else (if (eq? (car lst) var)
|
||||
(loop (cdr lst) ans)
|
||||
(loop (cdr lst) (cons (car lst) ans)))])))
|
||||
|
||||
(define (lc-direct-subst var val exp)
|
||||
(let ([fv-exp (lc-direct-free-vars exp)])
|
||||
(if (memq var fv-exp)
|
||||
(match exp
|
||||
[`(lambda ,vars ,body)
|
||||
(if (memq var vars)
|
||||
exp
|
||||
(let* ([fv-val (lc-direct-free-vars val)]
|
||||
[vars1 (map (lambda (var) (pick-new-name var fv-val)) vars)])
|
||||
`(lambda ,vars1 ,(lc-direct-subst
|
||||
var
|
||||
val
|
||||
(lc-direct-subst/l vars
|
||||
vars1
|
||||
body)))))]
|
||||
[`(let (,l-var ,exp) ,body)
|
||||
(if (eq? l-var var)
|
||||
`(let (,l-var ,(lc-direct-subst var val exp)) ,body)
|
||||
(let* ([fv-val (lc-direct-free-vars val)]
|
||||
[l-var1 (pick-new-name l-var fv-val)])
|
||||
`(let (,l-var1 ,(lc-direct-subst var val exp))
|
||||
,(lc-direct-subst
|
||||
var
|
||||
val
|
||||
(lc-direct-subst
|
||||
l-var
|
||||
l-var1
|
||||
body)))))]
|
||||
[(? number?) exp]
|
||||
[(and var1 (? symbol?))
|
||||
(if (eq? var1 var)
|
||||
val
|
||||
var1)]
|
||||
[`(,@(args ...))
|
||||
`(,@(map (lambda (arg) (lc-direct-subst var val arg)) args))])
|
||||
exp)))
|
||||
|
||||
;; lc-direct-subst/l : (listof symbol) (listof symbol) (listof symbol) sexp -> exp
|
||||
;; substitutes each of vars with vals in exp
|
||||
;; [assume vals don't contain any vars]
|
||||
(define (lc-direct-subst/l vars vals exp)
|
||||
(foldr (lambda (var val exp) (lc-direct-subst var val exp))
|
||||
exp
|
||||
vars
|
||||
vals))
|
||||
|
||||
;; lc-direct-free-vars : sexp -> (listof symbol)
|
||||
;; returns the free variables in exp
|
||||
(define (lc-direct-free-vars exp)
|
||||
(let ([ht (make-hash-table)])
|
||||
(let loop ([exp exp]
|
||||
[binding-vars null])
|
||||
(match exp
|
||||
[(? symbol?)
|
||||
(unless (memq exp binding-vars)
|
||||
(hash-table-put! ht exp #t))]
|
||||
[(? number?)
|
||||
(void)]
|
||||
[`(lambda ,vars ,body)
|
||||
(loop body (append vars binding-vars))]
|
||||
[`(let (,var ,exp) ,body)
|
||||
(loop exp binding-vars)
|
||||
(loop body (cons var binding-vars))]
|
||||
[`(,@(args ...))
|
||||
(for-each (lambda (arg) (loop arg binding-vars)) args)]))
|
||||
(hash-table-map ht (lambda (x y) x))))
|
||||
|
||||
;; pick-new-name : symbol (listof symbol) -> symbol
|
||||
;; returns a primed version of `var' that does
|
||||
;; not occur in vars (possibly with no primes)
|
||||
(define (pick-new-name var vars)
|
||||
(if (member var vars)
|
||||
(pick-new-name (prime var) vars)
|
||||
var))
|
||||
|
||||
;; prime : symbol -> symbol
|
||||
;; adds an @ at the end of the symbol
|
||||
(define (prime var)
|
||||
(string->symbol
|
||||
(string-append
|
||||
(symbol->string var)
|
||||
"@"))))
|
||||
Loading…
Reference in New Issue
Block a user