From 341d0c76a9bcacebcc959eb8982cf0b5d472f42c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 29 Jul 2008 21:46:15 +0000 Subject: [PATCH] adding redex to main SVN archive so it goes into the distribution svn: r10974 --- collects/redex/HISTORY | 417 ++++ collects/redex/doc.txt | 1679 +++++++++++++++++ collects/redex/examples/arithmetic.ss | 42 + collects/redex/examples/beginner.ss | 931 +++++++++ collects/redex/examples/church.ss | 57 + collects/redex/examples/combinators.ss | 90 + collects/redex/examples/compatible-closure.ss | 18 + collects/redex/examples/eta.ss | 67 + collects/redex/examples/info.ss | 2 + collects/redex/examples/iswim.ss | 254 +++ collects/redex/examples/letrec.ss | 155 ++ collects/redex/examples/omega.ss | 60 + collects/redex/examples/semaphores.ss | 169 ++ collects/redex/examples/subject-reduction.ss | 92 + collects/redex/examples/threads.ss | 117 ++ collects/redex/examples/types.ss | 87 + collects/redex/generator.ss | 252 +++ collects/redex/gui.ss | 64 + collects/redex/info.ss | 10 + collects/redex/pict.ss | 88 + collects/redex/private/arrow.ss | 122 ++ collects/redex/private/bitmap-test-util.ss | 164 ++ collects/redex/private/bitmap-test.ss | 44 + .../redex/private/bmps/extended-language.png | Bin 0 -> 2056 bytes .../bmps/extended-reduction-relation.png | Bin 0 -> 398 bytes collects/redex/private/bmps/language.png | Bin 0 -> 5851 bytes collects/redex/private/bmps/metafunction.png | Bin 0 -> 1081 bytes .../redex/private/bmps/reduction-relation.png | Bin 0 -> 1752 bytes collects/redex/private/color-test.ss | 71 + collects/redex/private/core-layout-test.ss | 55 + collects/redex/private/core-layout.ss | 739 ++++++++ collects/redex/private/dot.ss | 300 +++ collects/redex/private/info.ss | 2 + collects/redex/private/loc-wrapper.ss | 195 ++ collects/redex/private/lw-test-util.ss | 43 + collects/redex/private/lw-test.ss | 283 +++ collects/redex/private/matcher-test.ss | 799 ++++++++ collects/redex/private/matcher.ss | 1647 ++++++++++++++++ collects/redex/private/pict-test.ss | 58 + collects/redex/private/pict.ss | 777 ++++++++ .../redex/private/red-sem-macro-helpers.ss | 31 + collects/redex/private/reduction-semantics.ss | 1613 ++++++++++++++++ .../redex/private/rewrite-side-conditions.ss | 176 ++ collects/redex/private/rg-test.ss | 383 ++++ collects/redex/private/rg.ss | 393 ++++ collects/redex/private/run-tests.ss | 18 + collects/redex/private/schemeunit-test.ss | 60 + collects/redex/private/sexp-diffs.ss | 172 ++ collects/redex/private/size-snip.ss | 182 ++ collects/redex/private/stepper.ss | 882 +++++++++ collects/redex/private/struct.ss | 59 + collects/redex/private/subst-test.ss | 125 ++ collects/redex/private/term-fn.ss | 10 + collects/redex/private/term-test.ss | 87 + collects/redex/private/term.ss | 146 ++ collects/redex/private/test-util.ss | 109 ++ collects/redex/private/tl-test.ss | 990 ++++++++++ collects/redex/private/traces.ss | 614 ++++++ collects/redex/private/underscore-allowed.ss | 3 + collects/redex/reduction-semantics.ss | 65 + collects/redex/schemeunit.ss | 43 + collects/redex/subst.ss | 292 +++ 62 files changed, 16403 insertions(+) create mode 100644 collects/redex/HISTORY create mode 100644 collects/redex/doc.txt create mode 100644 collects/redex/examples/arithmetic.ss create mode 100644 collects/redex/examples/beginner.ss create mode 100644 collects/redex/examples/church.ss create mode 100644 collects/redex/examples/combinators.ss create mode 100644 collects/redex/examples/compatible-closure.ss create mode 100644 collects/redex/examples/eta.ss create mode 100644 collects/redex/examples/info.ss create mode 100644 collects/redex/examples/iswim.ss create mode 100644 collects/redex/examples/letrec.ss create mode 100644 collects/redex/examples/omega.ss create mode 100644 collects/redex/examples/semaphores.ss create mode 100644 collects/redex/examples/subject-reduction.ss create mode 100644 collects/redex/examples/threads.ss create mode 100644 collects/redex/examples/types.ss create mode 100644 collects/redex/generator.ss create mode 100644 collects/redex/gui.ss create mode 100644 collects/redex/info.ss create mode 100644 collects/redex/pict.ss create mode 100644 collects/redex/private/arrow.ss create mode 100644 collects/redex/private/bitmap-test-util.ss create mode 100644 collects/redex/private/bitmap-test.ss create mode 100644 collects/redex/private/bmps/extended-language.png create mode 100644 collects/redex/private/bmps/extended-reduction-relation.png create mode 100644 collects/redex/private/bmps/language.png create mode 100644 collects/redex/private/bmps/metafunction.png create mode 100644 collects/redex/private/bmps/reduction-relation.png create mode 100644 collects/redex/private/color-test.ss create mode 100644 collects/redex/private/core-layout-test.ss create mode 100644 collects/redex/private/core-layout.ss create mode 100644 collects/redex/private/dot.ss create mode 100644 collects/redex/private/info.ss create mode 100644 collects/redex/private/loc-wrapper.ss create mode 100644 collects/redex/private/lw-test-util.ss create mode 100644 collects/redex/private/lw-test.ss create mode 100644 collects/redex/private/matcher-test.ss create mode 100644 collects/redex/private/matcher.ss create mode 100644 collects/redex/private/pict-test.ss create mode 100644 collects/redex/private/pict.ss create mode 100644 collects/redex/private/red-sem-macro-helpers.ss create mode 100644 collects/redex/private/reduction-semantics.ss create mode 100644 collects/redex/private/rewrite-side-conditions.ss create mode 100644 collects/redex/private/rg-test.ss create mode 100644 collects/redex/private/rg.ss create mode 100644 collects/redex/private/run-tests.ss create mode 100644 collects/redex/private/schemeunit-test.ss create mode 100644 collects/redex/private/sexp-diffs.ss create mode 100644 collects/redex/private/size-snip.ss create mode 100644 collects/redex/private/stepper.ss create mode 100644 collects/redex/private/struct.ss create mode 100644 collects/redex/private/subst-test.ss create mode 100644 collects/redex/private/term-fn.ss create mode 100644 collects/redex/private/term-test.ss create mode 100644 collects/redex/private/term.ss create mode 100644 collects/redex/private/test-util.ss create mode 100644 collects/redex/private/tl-test.ss create mode 100644 collects/redex/private/traces.ss create mode 100644 collects/redex/private/underscore-allowed.ss create mode 100644 collects/redex/reduction-semantics.ss create mode 100644 collects/redex/schemeunit.ss create mode 100644 collects/redex/subst.ss diff --git a/collects/redex/HISTORY b/collects/redex/HISTORY new file mode 100644 index 0000000000..8161b4a192 --- /dev/null +++ b/collects/redex/HISTORY @@ -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 ..._ 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 + diff --git a/collects/redex/doc.txt b/collects/redex/doc.txt new file mode 100644 index 0000000000..6fc900e83a --- /dev/null +++ b/collects/redex/doc.txt @@ -0,0 +1,1679 @@ +_PLT Redex: Reduction Semantics_ +_PLT Redex: Operational Semantics_ + +This collection provides these files: + + _reduction-semantics.ss_: the core reduction semantics + library + + _gui.ss_: a _visualization tool for reduction sequences_. + + _pict.ss_: a library for _generating picts and postscript from semantics_ + + _subst.ss_: a library for _capture avoiding substitution_. + + _generator.ss_: automatically generates terms from a language + + _schemeunit.ss_: a _plt-redex specific library of schemeunit checks_. + +In addition, the examples subcollection contains several +small languages to demonstrate various different uses of +this tool: + + _arithmetic.ss_: an arithmetic language with every + possible order of evaluation + + _beginner.ss_: a PLT redex implementation of (much of) the + beginning student teaching language. + + _church.ss_: church numerals with call by name + normal order evaluation + + _combinators.ss_: fills in the gaps in a proof in + Barendregt that i and j (defined in the file) are + a combinator basis + + _compatible-closure.ss_: an example use of compatible + closure. Also, one of the first examples from Matthias + Felleisen and Matthew Flatt's monograph + + _eta.ss_: shows how eta is, in general, unsound. + + _ho-contracts.ss_: computes the mechanical portions of a + proof in the Contracts for Higher Order Functions paper + (ICFP 2002). Contains a sophisticated example use of an + alternative pretty printer. + + iswim.ss : see further below. + + _macro.ss_: models macro expansion as a reduction semantics. + + _letrec.ss_: shows how to model letrec with a store and + some infinite looping terms + + _omega.ss_: the call by value lambda calculus with call/cc. + Includes omega and two call/cc-based infinite loops, one of + which has an ever-expanding term size and one of which has + a bounded term size. + + _semaphores.ss_: a simple threaded language with semaphores + + _subject-reduction.ss_: demos traces/pred that type checks + the term. + + _threads.ss_: shows how non-deterministic choice can be + modeled in a reduction semantics. Contains an example use + of a simple alternative pretty printer. + + _types.ss_: shows how the simply-typed lambda calculus's + type system can be written as a rewritten system (see + Kuan, MacQueen, Findler in ESOP 2007 for more). + +====================================================================== + +The _reduction-semantics.ss_ library defines a pattern +language, used in various ways: + + pattern = any + | number + | string + | variable + | (variable-except ...) + | (variable-prefix ) + | variable-not-otherwise-mentioned + | hole + | (hole ) + | + | (name ) + | (in-hole ) + | (in-named-hole ) + | (hide-hole ) + | (side-condition ) + | (cross ) + | ( ...) + | + + pattern-sequence = pattern + | ... ;; literal ellipsis + | ..._ + +The patterns match sexpressions. The _any_ pattern matches +any sepxression. The _number_ pattern matches any +number. The _string_ pattern matches any string. Those three +patterns may also be suffixed with an underscore and another +identifier, in which case they bind the full name (as if it +were an implicit `name' pattern) and match the portion +before the underscore. + +The _variable_ pattern matches any symbol. The +_variable-except_ pattern matches any variable except those +listed in its argument. This is useful for ensuring that +keywords in the language are not accidentally captured by +variables. The _variable-prefix_ pattern matches any symbol +that begins with the given prefix. The +_variable-not-otherwise-mentioned_ pattern matches any +symbol except those that are used as literals elsewhere in +the language. + +The _hole_ pattern matches anything when inside a matching +in-hole pattern. The (hole ) variation on +that pattern is used in conjunction with in-named-hole to +support languages that require multiple patterns in a +hole. If the hole pattern is not being matched as part of +matching an in-hole pattern, it only matches the hole +(extracted as the result of some earlier match of the +in-hole pattern). + +NOTE: If you wish to make a two element list whose elements + are both holes, you must write this: + + ((hole #f) hole) + + If you were to write this: (hole hole), that would be + interpreted as a single hole whose name is "hole". + +The __ pattern stands for a literal symbol that must +match exactly, unless it is the name of a non-terminal in a +relevant language or contains an underscore. + +If it is a non-terminal, it matches any of the right-hand +sides of that non-terminal. + +If the symbol is a non-terminal followed by an underscore, +for example e_1, it is implicitly the same as a name pattern +that matches only the non-terminal, (name e_1 e) for the +example. Accordingly, repeated uses of the same name are +constrainted to match the same expression. + +If the symbol is a non-terminal followed by _!_, for example +e_!_1, it is also treated as a pattern, but repeated uses of +the same pattern are constrained to be different. For +example, this pattern: + + (e_!_1 e_!_1 e_!_1) + +matches lists of three "e"s, but where all three of them are +distinct. + +Unlike the _ patterns, the _!_ patterns do not bind names. + +If _ names and _!_ are mixed, they are treated as +separate. That is, this pattern (e_1 e_!_1) matches just the +same things as (e e), but the second doesn't bind any +variables. + +If the symbol otherwise has an underscore, it is an error. + +_name_: The pattern: + + (name ) + +matches and binds using it to the name . + +_in-hole_: The (in-hole ) matches the first +pattern. This match must include exactly one match against the second +pattern. If there are zero or more than one match, an +exception is raised. + +When matching the first argument of in-hole, the `hole' pattern +matches any sexpression. Then, the sexpression that matched the hole +pattern is used to match against the second pattern. + +_in-named-hole_: The pattern: + + (in-named-hole ) + +is similar in spirit to in-hole, except that it supports +languages with multiple holes in a context. The first +argument identifies which hole, using the (hole ) +pattern that this expression requires and the rest of the +arguments are just like in-hole. That is, if there are +multiple holes in a term, each matching a different (hole +) pattern, this one selects only the holes that are +named by the first argument to in-named-hole. + +_hide-hole_: The (hide-hole pattern) pattern matches what +the embedded pattern matches but if the pattern matcher is +looking for a decomposition, it ignores any holes found in +that pattern. + +_side-condition_: The (side-condition pattern guard) pattern matches +what the embedded pattern matches, and then the guard expression is +evaluated. If it returns #f, the pattern fails to match, and if it +returns anything else, the pattern matches. In addition, any +occurrences of `name' in the pattern are bound using `term-let' +(see below) in the guard. + +_cross_: The (cross ) pattern is used for the compatible +closure functions. If the language contains a non-terminal with the +same name as , the pattern (cross ) matches the +context that corresponds to the compatible closure of that +non-terminal. + +The (pattern-sequence ...) pattern matches a sexpression +list, where each pattern-sequence element matches an element +of the list. In addition, if a list pattern contains an +ellipsis, the ellipsis is not treated as a literal, instead +it matches any number of duplications of the pattern that +came before the ellipses (including 0). Furthermore, each +(name ) in the duplicated pattern binds a +list of matches to , instead of a single match. (A +nested duplicated pattern creates a list of list matches, +etc.) Ellipses may be placed anywhere inside the row of +patterns, except in the first position or immediately after +another ellipses. + +Multiple ellipses are allowed. For example, this pattern: + + ((name x a) ... (name y a) ...) + +matches this sexpression: + + (a a) + +three different ways. One where the first a in the pattern +matches nothing, and the second matches both of the +occurrences of `a', one where each named pattern matches a +single `a' and one where the first matches both and the +second matches nothing. + +If the ellipses is named (ie, has an underscore and a name +following it, like a variable may), the pattern matcher +records the length of the list and ensures that any other +occurrences of the same named ellipses must have the same +length. + +As an example, this pattern: + + ((name x a) ..._1 (name y a) ..._1) + +only matches this sexpression: + + (a a) + +one way, with each named pattern matching a single a. Unlike +the above, the two patterns with mismatched lengths is ruled +out, due to the underscores following the ellipses. + +Also, like underscore patterns above, if an underscore +pattern begins with ..._!_, then the lengths must be +different. + +Thus, with the pattern: + + ((name x a) ..._!_1 (name y a) ..._!_1) + +and the expression + + (a a) + +two matches occur, one where x is bound to '() and y is +bound to '(a a) and one where x is bound to '(a a) and y is +bound to '(). + +> (define-language (non-terminal-spec pattern ...) ...) SYNTAX + non-terminal-spec = symbol + | (symbol ...) + +This form defines the grammar of a language. It allows the +definition of recursive patterns, much like a BNF, but for +regular-tree grammars. It goes beyond their expressive +power, however, because repeated `name' patterns and +side-conditions can restrict matches in a context-sensitive +way. + +The non-terminal-spec can either by a symbol, indicating a +single name for this non-terminal, or a sequence of symbols, +indicating that all of the symbols refer to these +productions. + +As a simple example of a grammar, this is the lambda +calculus: + + (define-language lc-lang + (e (e e ...) + x + v) + (c (v ... c e ...) + hole) + (v (lambda (x ...) e)) + (x variable-not-otherwise-mentioned)) + +with non-terminals e for the expression language, x for +variables, c for the evaluation contexts and v for values. + +> (define-extended-language (non-terminal pattern ...) ...) + +This form extends a language with some new, replaced, or +extended non-terminals. For example, this language: + + (define-extended-language lc-num-lang + lc-lang + (e .... ;;; extend the previous `e' non-terminal + + + number) + (v .... + + + number) + (x (variable-except lambda +))) + +extends lc-lang with two new alternatives for both the `e' +and `v' nonterminal, replaces the `x' non-terminal with a +new one, and carries the `c' non-terminal forward. + +The four-period ellipses indicates that the new language's +non-terminal has all of the alternatives from the original +language's non-terminal, as well as any new ones. If a +non-terminal occurs in both the base language and the +extension, the extension's non-terminal replaces the +originals. If a non-terminal only occurs in either the base +language, then it is carried forward into the +extension. And, of course, extend-language lets you add new +non-terminals to the language. + +If a language is has a group of multiple non-terminals +defined together, extending any one of those non-terminals +extends all of them. + +> language-nts :: (compiled-lang? . -> . (listof symbol?)) + +Returns the list of non-terminals (as symbols) that are +defined by this language. + +> compiled-lang? :: (any? . -> . boolean?) + +Returns #t if its argument was produced by `language', #f +otherwise. + +> (term-let ([tl-pat expr] ...) body) SYNTAX + +Matches each given id pattern to the value yielded by +evaluating the corresponding expr and binds each variable in +the id pattern to the appropriate value (described +below). These bindings are then accessible to the `term' +syntactic form. + +Identifier-patterns are terms in the following grammar: + + tl-pat ::= identifier + | (tl-pat-ele ...) +tl-pat-ele ::= tl-pat + | tl-pat ellipses + +where ellipses is the literal symbol consisting of three +dots (and the ... indicates repetition as usual). If tl-pat +is an identifier, it matches any value and binds it to the +identifier, for use inside `term'. If it is a list, it +matches only if the value being matched is a list value and +only if every subpattern recursively matches the +corresponding list element. There may be a single ellipsis +in any list pattern; if one is present, the pattern before +the ellipses may match multiple adjacent elements in the +list value (possibly none). + +> (term s-expr) SYNTAX + +This form is used for construction of new s-expressions in +the right-hand sides of reductions. It behaves similarly to +quasiquote except for a few special forms that are +recognized (listed below) and that names bound by `term-let' are +implicitly substituted with the values that those names were +bound to, expanding ellipses as in-place sublists (in the +same manner as syntax-case patterns). + +For example, + +(term-let ([body '(+ x 1)] + [(expr ...) '(+ - (values * /))] + [((id ...) ...) '((a) (b) (c d))]) + (term (let-values ([(id ...) expr] ...) body))) + +evaluates to + +'(let-values ([(a) +] + [(b) -] + [(c d) (values * /)]) + (+ x 1)) + +It is an error for a term variable to appear in an +expression with an ellipsis-depth different from the depth +with which it was bound by `term-let'. It is also an error +for two `term-let'-bound identifiers bound to lists of +different lengths to appear together inside an ellipsis. + +The special forms recognized by term are: + + (in-hole a b) + + This is the dual to the pattern `in-hole' -- it accepts + a context and an expression and uses `plug' to combine + them. + + (in-named-hole name a b) + + Like in-hole, but substitutes into a hole with a particular name. + + hole + + This produces a hole. + + (hole name) + + This produces a hole with the name `name'. To produce an unnamed + hole, use #f as the name. + +> (term-match [ (term-match/single [ (reduction-relation ...) SYNTAX + + = (--> ...) + = + + | (fresh ...) + | (side-condition ...) + | (where e) + = + var + | ((var1 ...) (var2 ...)) + +Defines a reduction relation casewise, one case for each of +the clauses beginning with -->. Each of the s +refers to the , and binds variables in the +. The behave like the argument to `term'. + +Following the lhs & rhs specs can be the name of the +reduction rule, declarations of some fresh variables, and/or +some side-conditions. The can either be a literal +name (identifier), or a literal string. + +The fresh variables clause generates variables that do not +occur in the term being matched. If the is a +variable, that variable is used both as a binding in the +rhs-exp and as the prefix for the freshly generated +variable. + +The second case of a is used when you want to +generate a sequence of variables. In that case, the ellipses +are literal ellipses; that is, you must actually write +ellipses in your rule. The variable var1 is like the +variable in first case of a , namely it is +used to determine the prefix of the generated variables and +it is bound in the right-hand side of the reduction rule, +but unlike the single-variable fresh clause, it is bound to +a sequence of variables. The variable var2 is used to +determine the number of variables generated and var2 must be +bound by the left-hand side of the rule. + +The side-conditions are expected to all hold, and have the +format of the second argument to the side-condition pattern, +described above. + +Each where clauses binds a variable and the side-conditions +(and where clauses) that follow the where declaration are in +scope of the where declaration. The bindings are the same as +bindings in a term-let expression. + +As an example, this + + (reduction-relation + lc-lang + (--> (in-hole c_1 ((lambda (variable_i ...) e_body) v_i ...)) + (in-hole c_1 ,(foldl lc-subst + (term e_body) + (term (v_i ...)) + (term (variable_i ...)))) + beta-v)) + +defines a reduction relation for the lambda-calculus above. + +> (reduction-relation + + ( ) ... + with + [( ) + ( )] ...) + +Defines a reduction relation with shortcuts. As above, the +first section defines clauses of the reduction relation, but +instead of using -->, those clauses can use any identifier +for an arrow, as long as the identifier is bound after the +`with' clause. + +Each of the clauses after the `with' define new relations +in terms of other definitions after the `with' clause or in +terms of the main --> relation. + +[ NOTE: `fresh' is always fresh with respect to the entire + term, not just with respect to the part that matches the + right-hand-side of the newly defined arrow. ] + +For example, this + + (reduction-relation + lc-num-lang + (==> ((lambda (variable_i ...) e_body) v_i ...) + ,(foldl lc-subst + (term e_body) + (term (v_i ...)) + (term (variable_i ...)))) + (==> (+ number_1 ...) + ,(apply + (term (number_1 ...)))) + + with + [(--> (in-hole c_1 a) (in-hole c_1 b)) + (==> a b)]) + +defines reductions for the lambda calculus with numbers, +where the ==> relation is defined by reducing in the context +c. + +> (extend-reduction-relation ...) + +This form extends the reduction relation in its first +argument with the rules specified in . They should +have the same shape as the the rules (including the `with' +clause) in an ordinary reduction-relation. + +If the original reduction-relation has a rule with the same +name as one of the rules specified in the extension, the old +rule is removed. + +In addition to adding the rules specified to the existing +relation, this form also reinterprets the rules in the +original reduction, using the new language. + +> union-reduction-relations :: (reduction-relation? ... -> reduction-relation?) + +Combines all of the argument reduction relations into a +single reduction relation that steps when any of the +arguments would have stepped. + +> reduction-relation->rule-names :: + (reduction-relation? . -> . (listof (union false/c symbol?))) + +Returns the names of all of the reduction relation's clauses +(or false if there is no name for a given clause). + +> (compatible-closure ) SYNTAX + +This accepts a reduction, a language, the name of a +non-terminal in the language and returns the compatible +closure of the reduction for the specified non-terminal. + +> (context-closure ) SYNTAX + +This accepts a reduction, a language, a pattern representing +a context (ie, that can be used as the first argument to +`in-hole'; often just a non-terminal) in the language and +returns the closure of the reduction in that context. + +> (define-metafunction name + [ (side-condition ) ...] ...) SYNTAX + +The `define-metafunction' form builds a function on +sexpressions according to the pattern and right-hand-side +expressions. The first argument indicates the language used +to resolve non-terminals in the pattern expressions. Each of +the rhs-expressions is implicitly wrapped in `term'. In +addition, recursive calls in the right-hand side of the +metafunction clauses should appear inside `term'. + +If specified, the side-conditions are collected with an +`and' and used as guards on the case being matched. The +argument to each side-condition should be a Scheme +expression, and the pattern variables in the are +bound in that expression. + +As an example, this metafunction finds the free variables in +an expression in the lc-lang above: + + ;; 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 ...)))]) + +The first argument to define-metafunction is the grammar +(defined above). Following that are three cases, one for +each variation of expressions (e in lc-lang). The right-hand +side of each clause begins with a comma, since they are +implicitly wrapped in `term'. The free variables of an +application are the free variables of each of the subterms; +the free variables of a variable is just the variable +itself, and the free variables of a lambda expression are +the free variables of the body, minus the bound parameters. + +> (define-metafunction/extension name extending-name + [ (side-condition ) ...] ...) SYNTAX + +This defines a metafunction as an extension of an existing +one. The extended metafunction behaves as if the original +patterns were in this definitions, with the name of the +function fixed up so that recursive functions behave as expected. + +> (define-multi-args-metafunction name + [ (side-condition ) ...] ...) SYNTAX + +Like define-metafunction, this defines a +metafunction. Unlike it, this defines a metafunction that +accepts multiple arguments. + +There are two significant differences: + + - patterns match the entire argument list, rather than just + matching the single argument + - the typesetting for define-multi-args-metafunction uses + commas to separate the arguments in the definition + and at the callsites. + +> (define-multi-arg-metafunction/extension name extending-name + [ (side-condition ) ...] ...) SYNTAX + +Like define-metafunction/extension, this defines a +metafunction as an extension of an existing one, but this +time for multi-argument metafunctions. + +> (in-domain? ) + +Returns #t if is in the domain of the specified +metafunction. + +If the metafunction is defined with define-metafunction, +then the term representing the argument should appear +exactly as it appears in a call to the metafunction. + +If the metafunction is defined with +define-multi-args-metafunction, then the arguments should +be parenthesized. + +> (test-equal e1 e2) SYNTAX + +Tests to see if e1 is equal to e2. + +> (test--> reduction-relation e1 e2 ...) SYNTAX + +Tests to see if the value of e1 (which should be a term), +reduces to the e2s. + +> (test-predicate p? e) SYNTAX + +Tests to see if the value of `e' matches the predicate p?. + +> test-results :: (-> void?) + +Prints out how many tests passed and failed, and resets the +counters so that next time this function is called, it +prints the test results for the next round of tests. + +> plug :: (any? any? . -> . any) + +The first argument to this function is an sexpression to +plug into. The second argument is the sexpression to replace +in the first argument. It returns the replaced term. This is +also used when a `term' sub-expression contains `in-hole'. + +> apply-reduction-relation :: (reduction-relation? any? . -> . (listof any?)) + +Reduce accepts a list of reductions, a term, and returns a +list of terms that the term reduces to. + +> apply-reduction-relation/tag-with-names :: + (-> reduction-relation? + any/c + (listof (list/c (union false/c string?) any/c))) + +Like apply-reduction-relation, but the result indicates the +names of the reductions that were used. + +> apply-reduction-relation* :: + (reduction-relation? any? . -> . (listof (listof any?)) + +apply-reduction-relation* accepts a list of reductions and a +term. It returns the results of following every reduction +path from the term. If there are infinite reduction +sequences starting at the term, this function will not +terminate. + +> (redex-match lang pattern any) SYNTAX + +Matches the pattern (in the language) against the third +expression. If it matches, this returns a list of match +structures describing the matches. If it fails, it returns +#f. + +> (redex-match lang pattern) SYNTAX + +Builds a procedure for efficiently testing if expressions +match the pattern `pattern' in the language `lang'. The +procedures accepts a single expression and if the expresion +matches, it returns a list of match structures describing the +matches. If the match fails, the procedure returns #f. + +> match? :: (any/c . -> . boolean?) + +Determines if a value is a mtch structure. + +> match-bindings :: (mtch? -> (listof bind?)) + +This returns a bindings structure (see below) that +binds the pattern variables in this match. + +> variable-not-in :: (any? symbol? . -> . symbol?) + +This helper function accepts an sexpression and a +variable. It returns a variable not in the sexpression with +a prefix the same as the second argument. + +> variables-not-in :: (any? (listof symbol?) . -> . (listof symbol?)) + +This function, like variable-not-in, makes variables that do +no occur in its first argument, but it returns a list of +such variables, one for each variable in its second +argument. + +Does not expect the input symbols to be distinct, but does +produce variables that are always distinct. + +> make-bind :: (symbol? any? . -> . bind?) +> bind? :: (any? . -> . boolean?) +> bind-name :: (bind? . -> . symbol?) +> bind-exp :: (bind? . -> . any?) + +Constructor, predicate, and selector functions for the rib +values contained within a bindings (returned by redex-match). +Each rib associates a name with an s-expression from the +language, or a list of such s-expressions, if the (name ...) +clause is followed by an ellipsis. Nested ellipses produce +nested lists. + +> set-cache-size! :: (union #f positive-integer) -> void + +Changes the cache size; a #f disables the cache +entirely. The default size is 350. + +The cache is per-pattern (ie, each pattern has a cache of +size at most 350 (by default)) and is a simple table that +maps expressions to how they matched the pattern. When the +cache gets full, it is thrown away and a new cache is +started. + +_Debugging PLT Redex Programs_ + +It is easy to write grammars and reduction rules that are +subtly wrong and typically such mistakes result in examples +that just get stuck when viewed in a `traces' window. + +The best way to debug such programs is to find an expression +that looks like it should reduce but doesn't and try to find +out what pattern is failing to match. To do so, use the +redex-match special form, described above. + +In particular, first ceck to see if the term matches the +main non-terminal for your system (typically the expression +or program nonterminal). If it does not, try to narrow down +the expression to find which part of the term is failing to +match and this will hopefully help you find the problem. If +it does match, figure out which reduction rule should have +matched, presumably by inspecting the term. Once you have +that, extract a pattern from the left-hand side of the +reduction rule and do the same procedure until you find a +small example that shoudl work but doesn't (but this time +you might also try simplifying the pattern as well as +simplifying the expression). + + +====================================================================== + +The _gui.ss_ library provides the following functions: + +> (stepper reductions expr [pp]) :: + (opt-> (compiled-lang? + reduction-relation? + any/c) + ((or/c (any -> string) + (any output-port number (is-a?/c text%) -> void))) + void?) + +This function opens a stepper window for exploring the +behavior of its third argument in the reduction system +described by its first two arguments. + +The pp function is used to specially print expressions. It +must either accept one or four arguments. If it accepts one +argument, it will be passed each term and is expected to +return a string to display the term. + +If the pp function takes four arguments, it should render +its first argument into the port (its second argument) with +width at most given by the number (its third argument). The +final argument is the text where the port is connected -- +characters written to the port go to the end of the editor. + +The default pp, provided as default-pretty-printer, uses +MzLib's pretty-print function. See threads.ss in the +examples directory for an example use of the one-argument +form of this argument and ho-contracts.ss in the examples +directory for an example use of its four-argument form. + +> (stepper/seed reductions seed [pp]) :: + (opt-> (compiled-lang? + reduction-relation? + (cons/c any/c (listof any/c))) + ((or/c (any -> string) + (any output-port number (is-a?/c text%) -> void))) + void?) + +Like `stepper', this function opens a stepper window, but it +seeds it with the reduction-sequence supplied in `terms'. + +> (traces reductions expr + #:pred [pred (lambda (x) #t)] + #:pp [pp default-pretty-printer] + #:colors [colors '()] + #:multiple? [multiple? #f]) + lang : language + reductions : (listof reduction) + expr : (or/c (listof sexp) sexp) + multiple : boolean --- controls interpretation of expr + pred : (or/c (sexp -> any) + (sexp term-node? any)) + pp : (or/c (any -> string) + (any output-port number (is-a?/c text%) -> void)) + colors : (listof (list string string)) + +This function opens a new window and inserts each expression +in expr (if multiple is #t -- if multiple is #f, then expr +is treated as a single expression). Then, it reduces the +terms until either reduction-steps-cutoff (see below) +different terms are found, or no more reductions can +occur. It inserts each new term into the gui. Clicking the +`reduce' button reduces until reduction-steps-cutoff more +terms are found. + +The pred function indicates if a term has a particular +property. If it returns #f, the term is displayed with a +pink background. If it returns a string or a color% object, +the term is displayed with a background of that color (using +the-color-database<%> to map the string to a color). If it +returns any other value, the term is displayed normally. If +the pred function accepts two arguments, a term-node +corresponding to the term is passed to the predicate. This +lets the predicate function explore the (names of the) +reductions that led to this term, using term-node-children, +term-node-parents, and term-node-labels. + +The pred function may be called more than once per node. In +particular, it is called each time an edge is added to a +node. The latest value returned determines the color. + +The pp argument is the same as to the stepper functions +(above). + +The colors argument, if provided, specifies a list of +reduction-name/color-string pairs. The traces gui will color +arrows drawn because of the given reduction name with the +given color instead of using the default color. + +You can save the contents of the window as a postscript file +from the menus. + +> term-node-children :: (-> term-node (listof term-node)) + +Returns a list of the children (ie, terms that this term +reduces to) of the given node. + +Note that this function does not return all terms that this +term reduces to -- only those that are currently in the +graph. + +> term-node-parents :: (-> term-node (listof term-node)) + +Returns a list of the parents (ie, terms that reduced to the +current term) of the given node. + +Note that this function does not return all terms that +reduce to this one -- only those that are currently in the +graph. + +> term-node-labels :: (-> term-node (listof (union false/c string))) + +Returns a list of the names of the reductions that led to +the given node, in the same order as the result of +term-node-parents. If the list contains #f, that means that +the corresponding step does not have a label. + +> term-node-set-color! :: + (-> term-node? + (or/c string? (is-a?/c color%) false/c) + void?) + +Changes the highlighting of the node; if its second argument +is #f, the coloring is removed, otherwise the color is set +to the specified color% object or the color named by the +string. The color-database<%> is used to convert the string +to a color% object. + +> term-node-set-red! :: (-> term-node boolean void?) + +Changes the highlighting of the node; if its second argument +is #t, the term is colored pink, if it is #f, the term is +not colored specially. + +> term-node-expr :: (-> term-node any) + +Returns the expression in this node. + +> term-node? :: (-> any boolean) + +Recognizes term nodes. + +> (reduction-steps-cutoff) +> (reduction-steps-cutoff number) + +A parameter that controls how many steps the `traces' function +takes before stopping. + +> (initial-font-size) +> (initial-font-size number) + +A parameter that controls the initial font size for the terms shown +in the GUI window. + +> (initial-char-width) +> (initial-char-width number) + +A parameter that determines the initial width of the boxes +where terms are displayed (measured in characters) for both +the stepper and traces. + +> (dark-pen-color color-or-string) +> (dark-pen-color) => color-or-string + +> (dark-brush-color color-or-string) +> (dark-brush-color) => color-or-string + +> (light-pen-color color-or-string) +> (light-pen-color) => color-or-string + +> (light-brush-color color-or-string) +> (light-brush-color) => color-or-string + +These four parameters control the color of the edges in the graph. + +====================================================================== + +The _pict.ss_ library provides functions designed to +automatically typeset grammars, reduction relations, and +metafunction written with plt redex. + +Each grammar, reduction relation, and metafunction can be +saved in a .ps file (as encapsulated postscript), or can be +turned into a pict. + +Picts are more useful for debugging since DrScheme REPL will +show you the pict directly (albeit with slightly different +fonts than you'd see in the .ps file). You can also use the +picts with Slideshow's pict library to build more complex +arrangements of the figures and add other picts. See +Slideshow for details. + +If you are only using the picts to experiment in DrScheme's +REPL, be sure your program is in the GUI library, and +contains this header: + + #lang scheme/gui + (require texpict/mrpict) + (dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))) + +Be sure to remove the call to dc-for-text-size before you +generate .ps files, otherwise the font spacing will be wrong +in the .ps file. + +> language->pict :: + (->* (compiled-lang? + (or/c false/c (cons/c symbol? (listof symbol?)))) + ((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?) + +These two functions turn a languages into picts. The first +argument is the language, and the second is a list of +non-terminals that should appear in the pict. It may only +contain symbols that are in the language's set of +non-terminals. + +For language->ps, the path argument is a filename for the +PostScript file. + +> extend-language-show-union : (parameter/c boolean?) + +If this is #t, then a language constructed with +extend-language is shown as if the language had been +constructed directly with `language'. If it is #f, then only +the last extension to the language is shown (with +four-period ellipses, just like in the concrete syntax). + +Defaultly #f. + +Note that the #t variant can look a little bit strange if +.... are used and the original version of the language has +multi-line right-hand sides. + +> reduction-relation->pict :: + (opt-> (reduction-relation?) + ((or/c false/c (listof (union string? symbol?)))) + pict?) + +> reduction-relation->ps :: + (opt-> (reduction-relation? + (union string? path?)) + ((or/c false/c (listof (union string? symbol?)))) + void?) + +These two functions turn reduction relations into picts. + +The optional lists determine which reduction rules are shown +in the pict. + +> (metafunction->pict metafunction-name) -> pict +> (metafunction->ps metafunction-name (union path? string?)) -> void + +These two syntactic forms turn metafunctions into picts + +There are also customization parameters: + +> rule-pict-style :: + (parameter/c (symbols 'vertical + 'compact-vertical + 'vertical-overlapping-side-conditions + 'horizontal)) + +This parameter controls the style used for the reduction +relation. It can be either horizontal, where the left and +right-hand sides of the reduction rule are beside each other +or vertical, where the left and right-hand sides of the +reduction rule are above each other. The vertical mode also +has a variant where the side-conditions don't contribute to +the width of the pict, but are just overlaid on the second +line of each rule. + +> arrow-space :: (parameter/c natural-number/c) + +This parameter controls the amount of extra horizontal space +around the reduction relation arrow. Defaults to 0. + +> horizontal-label-space :: (parameter/c natural-number/c) + +This parameter controls the amount of extra space before the +label on each rule, but only in horizontal mode. Defaults to +0. + +> metafunction-pict-style :: + (parameter/c (symbols 'left-right 'up-down)) + +This parameter controls the style used for typesetting +metafunctions. The 'left-right style means that the +results of calling the metafunction are displayed to the +right of the arguments and the 'up-down style means that +the results are displayed below the arguments. + +> label-style :: (parameter/c text-style/c) +> literal-style :: (parameter/c text-style/c) +> metafunction-style :: (parameter/c text-style/c) +> non-terminal-style :: (parameter/c text-style/c) +> non-terminal-subscript-style :: (parameter/c text-style/c) +> default-style :: (parameter/c text-style/c) + +These parameters determine the font used for various text in +the picts. See `text' in the texpict collection for +documentation explaining text-style/c. One of the more +useful things it can be is one of the symbols 'roman, +'swiss, or 'modern, which are a serif, sans-serif, and +monospaced font, respectively. (It can also encode style +information, too.) + +The label-style is used for the reduction rule label +names. The literal-style is used for names that aren't +non-terminals that appear in patterns. The +metafunction-style is used for the names of +metafunctions. The non-terminal-style is for non-terminals +and non-terminal-subscript-style is used for the portion +after the underscore in non-terminal references. + +The default-style is used for parenthesis, the dot in dotted +lists, spaces, the separator words in the grammar, the +"where" and "fresh" in side-conditions, and other places +where the other parameters aren't used. + +> label-font-size :: (parameter/c (and/c (between/c 1 255) integer?)) +> metafunction-font-size :: (parameter/c (and/c (between/c 1 255) integer?)) +> default-font-size :: (parameter/c (and/c (between/c 1 255) integer?)) + +These parameters control the various font sizes. The +default-font-size is used for all of the font sizes except +labels and metafunctions. + +> reduction-relation-rule-separation :: + (parameter/c (and/c integer? positive? exact?)) + +Controls the amount of space between clauses in a reduction +relation. Defaults to 4. + +> curly-quotes-for-strings :: (parameter/c boolean?) + +Controls if the open and close quotes for strings are turned +into “ and ” or are left as merely ". + +Defaults to #t. + +> current-text :: (parameter/c (-> string? text-style/c number? pict?)) + +This parameter's function is called whenever Redex typesets +some part of a grammar, reduction relation, or +metafunction. It defaults to mrpict.ss's `text' function. + +> set-arrow-pict! :: (-> symbol? (-> pict?) void?) + +This functions sets the pict for a given reduction-relation +symbol. When typesetting a reduction relation that uses the +symbol, the thunk will be invoked to get a pict to render +it. The thunk may be invoked multiple times when rendering a +single reduction relation. + +============================================================ + +_Removing the pink background from PLT Redex rendered picts and ps files_ +_Rewriting patterns during typesetting for PLT Redex_ + +When reduction rules, a metafunction, or a grammar contains +unquoted Scheme code or side-conditions, they are rendered +with a pink background as a guide to help find them and +provide alternative typesettings for them. In general, a +good goal for a PLT Redex program that you intend to typeset +is to only include such things when they correspond to +standard mathematical operations, and the Scheme code is an +implementation of those operations. + +To replace the pink code, use: + +> (with-unquote-rewriter proc expression) + +It installs `proc' the current unqoute rewriter and +evaluates expression. If that expression computes any picts, +the unquote rewriter specified is used to remap them. + +The 'proc' should be a function of one argument. It receives +a lw struct as an argument and should return +another lw that contains a rewritten version of the +code. + +> (with-atomic-rewriter name-symbol string-or-thunk-returning-pict expression) + +This extends the current set of atomic-rewriters with one +new one that rewrites the value of name-symbol to +string-or-pict-returning-thunk (applied, in the case of a +thunk), during the evaluation of expression. + +name-symbol is expected to evaluate to a symbol. The value +of string-or-thunk-returning-pict is used whever the symbol +appears in a pattern. + +> (with-compound-rewriter name-symbol proc expression) + +This extends the current set of compound-rewriters with one +new one that rewrites the value of name-symbol via proc, +during the evaluation of expression. + +name-symbol is expected to evaluate to a symbol. The value +of proc is called with a (listof lw) -- see below +for details on the shape of lw, and is expected to +return a new (listof (union lw string pict)), +rewritten appropriately. + +The list passed to the rewriter corresponds to the +lw for the sequence that has name-symbol's value at +its head. + +The result list is constrained to have at most 2 adjacent +non-lws. That list is then transformed by adding +lw structs for each of the non-lws in the +list (see the description of lw below for an +explanation of logical-space): + + 0: If there are two adjacent lws, then the logical + space between them is filled with whitespace. + + 1: If there is a pair of lws with just a single + non-lw between them, a lw will be + created (containing the non-lw) that uses all + of the available logical space between the lws. + + 2: If there are two adjacent non-lws between two + lws, the first non-lw is rendered + right after the first lw with a logical space + of zero, and the second is rendered right before the + last lw also with a logical space of zero, and + the logical space between the two lws is + absorbed by a new lw that renders using no + actual space in the typeset version. + +============================================================ + +The lw data structure corresponds represents a +pattern or a Scheme expression that is to be typeset. + +A _lw_ is a struct: + (build-lw element posnum posnum posnum posnum) +with selectors: +> lw-e :: lw -> element +> lw-line :: lw -> posnum +> lw-line-span :: lw -> posnum +> lw-column :: lw -> posnum +> lw-column-span :: lw -> posnum + +An _element_ is either: + string + symbol + pict + (listof lw) + +Each sub-expression corresponds to its own lw, and +the element indicates what kind of subexpression it is. If +the element is a list, then the lw corresponds to a +parenthesized sequence, and the list contains a lw +for the open paren, one lw for each component of the +sequence and then a lw for the close +parenthesis. In the case of a dotted list, there will also +be a lw in the third-to-last position for the dot. + +For example, this expression: + + (a) + +becomes this lw (assuming the above expression +appears as the first thing in the file): + + (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) + +If there is some whitespace in the sequence, like this one: + + (a b) + +then there is no lw that corresponds to that +whitespace; instead there is a logical gap between the +lws. + + (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) + +In general, identifiers are represented with symbols and +parenthesis are represented with strings and picts can be +inserted to render arbitrary pictures. + +The line, line-span, column, and column-span correspond to +the logical spacing for the redex program, not the actual +spacing that will be used when they are rendered. The +logical spacing is only used when determining where to place +typeset portions of the program. In the absense of any +rewriters, these numbers correspond to the line and column +numbers in the original program. + +The line and column are absolute numbers from the beginning +of the file containing the expression. The column number is +not necessarily the column of the open parenthesis in a +sequence -- it is the leftmost column that is occupied by +anything in the sequence. The line-span is the number of +lines, and the column span is the number of columns on the +last line (not the total width). + +When there are multiple lines, lines are aligned based on +the logical space (ie, the line/column & +line-span/column-span) fields of the lws. As an +example, if this is the original pattern: + + (all good boys + deserve fudge) + +then the leftmost edges of the words "good" and "deserve" +will be lined up underneath each other, but the relative +positions of "boys" and "fudge" will be determined by the +natural size of the words as they rendered in the +appropriate font. + +There are two helper functions that make building +lws easier: + +> just-before :: (-> (or/c pict? string? symbol?) + lw? + lw?) +> just-after :: (-> (or/c pict? string? symbol?) + lw? + lw?) + +These functions build new lws whose contents are +the first argument, and whose line and column are based on +the second argument, making the new loc wrapper be either +just before or just after that argument. The line-span and +column-span of the new lw is always zero. + +> (to-lw arg) SYNTAX + +This form turns its argument into lw structs that +contain all of the spacing information just as it would appear +when being used to typeset. + +====================================================================== + +The _subst.ss_ library provides these names: + +> (subst (match-pattern subst-rhs ...) ...) SYNTAX + +The result of this form is a function that performs capture +avoiding substitution for a particular (sexp-based) +language. The function accepts three arguments, a variable, +a term to substitute and a term to substitute into. + +Each of the `match-pattern's specify the forms of +the language and the `subst-rhs's specify what kind of form +it is. Each of the match-patterns are in (lib "match.ss" +"match")'s pattern language and any variable that they bind +are available in the 's described below. + +The language of the subst-rhs follows. + +> (variable) + + this means that the rhs for this form is a symbol that + should be treated like a variable. Nothing may follow + this. + +> (constant) + + this means that the rhs for this form is a constant that + cannot be renamed. Nothing may follow this. + +> (all-vars ) + +This form indicates that this pattern in the language binds +the variables produced by the +. + +Immediately following this in a subst-rhs must be a (build +...) form and some number of (subterm ...) or (subterms ...) +forms. + +> (build ) + +This form must come right after an (all-vars ...) form and +before any (subterm ...) or (subterms ...) forms. + +This form tells subst how to reconstruct this term. The + must evaluate to a procedure that +accepts the (possibly renamed) variables from the all-vars +clause, and one argument for each of the subterms that +follow this declaration (with subterms flattened into the +argument list) in the same order that the subterm or +subterms declarations are listed. + +> (subterm ) + +The first must be a list of variables +that is a sub-list of the variables in the all-vars +expression. The second expression must be an sexp +corresponding to one of the subexpressions of this +expression (matched by the match-patten for this clause of +subst). + +> (subterms ) + +The first must be a list of variables +that is a sub-list of the variables in the all-vars +expression. The second expression must be an sexp +corresponding to one of the subexpressions of this +expression (matched by the match-patten for this clause of +subst). + +Consider this example of a substitution procedure for the +lambda calculus: + + (define lc-subst + (subst + [`(lambda ,vars ,body) + (all-vars vars) + (build (lambda (vars body) `(lambda ,vars ,body))) + (subterm vars body)] + [(? symbol?) (variable)] + [(? number?) (constant)] + [`(,fun ,@(args ...)) + (all-vars '()) + (build (lambda (vars fun . args) `(,fun ,@args))) + (subterm '() fun) + (subterms '() args)])) + +The first clause matches lambda expressions with any number +of arguments and says that there is one subterm, the body of +the lambda, and that all of the variables are bound in it. + +The second clause matches symbols and indicates that they +are variables. + +The third clause matches numbers and indicates that they are +constants. + +The final clause matches function applications. The +`all-vars' shows that applications introduce no new +names. The build procedure reconstructs a new application +form. The subterm declaration says that the function +position is a subterm with no variables bound in it. The +subterms declaration says that all of the arguments are +subterms and that they do not introduce any new terms. + +In this program, lc-subst is bound to a function that does +the substitution. The first argument is the variable to +substitute for, the second is the term to substitute and the +final argument is the term to substitute into. For example, +this call: + + (lc-subst 'q + '(lambda (x) y) + '((lambda (y) (y q)) (lambda (y) y))) + +produces this output: + + '((lambda (y@) (y@ (lambda (x) y))) (lambda (y) y)) + +This library also provides: + +> (plt-subst (match-pattern subst-rhs ...) ...) SYNTAX + +This is identical to subst, described above, except that +the pattern language used is that from (lib "plt-match.ss"), +instead of (lib "match.ss"). + +> subst/proc +> alpha-rename +> free-vars/memoize + +Theses functions are the procedure-based interface to +substitution that subst expands to and uses. + +====================================================================== + +The _iswim.ss_ module in the "examples" sub-collection defines a +grammar and reductions from "Programming Languages and Lambda Calculi" +by Felleisen and Flatt. + + Example S-expression forms of ISWIM expressions: + Book S-expr + ---- ------ + (lambda x . x) ("lam" x x) + (+ '1` '2`) ("+" 1 2) + ((lambda y y) '7`) (("lam" y y) 7) + + CK machine: + Book S-expr + ---- ------ + <(lambda x . x), mt> (("lam" x x) : "mt") + + CEK machine: + Book S-expr + ---- ------ + <<(lambda x . x), ((("lam" x x) + {>}>, : ((X (5 : ())))) + mt> : "mt") + + The full grammar: + + (language (M (M M) + (o1 M) + (o2 M M) + V) + (V X + ("lam" variable M) + b) + (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)) + + ;; 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-))) + + The following are provided by "iswim.ss": + + Grammar and substitution: +> iswim-grammar :: compiled-lang? +> M? :: (any? . -> . boolean?) +> V? :: (any? . -> . boolean?) +> o1? :: (any? . -> . boolean?) +> o2? :: (any? . -> . boolean?) +> on? :: (any? . -> . boolean?) +> k? :: (any? . -> . boolean?) +> env? :: (any? . -> . boolean?) +> cl? :: (any? . -> . boolean?) +> vcl? :: (any? . -> . boolean?) +> k-? :: (any? . -> . boolean?) +> iswim-subst :: (M? symbol? M? . -> . M?) +> empty-env :: env? +> env-extend :: (env? symbol? vcl? . -> . env?) +> env-lookup :: (env? symbol? . -> . (union false? vcl?)) + Reductions: +> beta_v :: reduction-relation? +> delta :: reduction-relation? +> ->v :: reduction-relation? +> :->v :: reduction-relation? + Abbreviations: +> if0 :: (M? M? M? . -> . M?) +> true :: M? +> false :: M? +> mkpair :: M? +> fst :: M? +> snd :: M? +> Y_v :: M? +> sum :: M? + Helpers: +> delta*1 :: (o1? V? . -> . (union false? V?)) + delta as a function for unary operations. +> delta*2 :: (o2? V? V? . -> . (union false? V?)) + delta as a function for binary operations. +> delta*n :: (on? (listof V?) . -> . (union false? V?)) + delta as a function for any operation. + +====================================================================== + +The _generator.ss_ module provides a tool for generating instances of +a grammar non-terminal. + +> lang->generator-table :: (lang? + (listof number?) + (listof symbol?) + (listof string?) + (listof symbol?) + number? + . -> . + generator-table?) + + Prepares generator information for a particular language, + given a set of numbers to use for the `number' keyword, + a set of symbols for `variable' and `variable-except', + and a set of string for `string'. + + The fifth argument lists keywords that appear in the grammar but + that should be skipped (to limit the generation space). The last + argument should be 0, and it is currently ignored. + +> for-each-generated :: (generator-table? + (any? number? . -> . any) + generator-table? + symbol? + . -> . any) + + The first argument is a procedure to call with a series of generated + grammar instances and each term's size. Instances are generated from + smallest to largest; the size of an instance is roughly the size of + the proof tree that demonstrates grammar membership. + + The second argument is a generator table created with + `lang->generator-table'. + + The third argument is a symbol, the name of a non-terminal for which + instances should be generated. + +> for-each-generated/size :: (generator-table? + (any? number? . -> . any) + generator-table? + symbol? + . -> . any) + + Like `for-each-generated', except minimum and maximum sizes are + provided, and the order of generation is arbitrary (i.e., some + larger instances may be generated before smaller instances). + +====================================================================== + +_schemeunit.ss_: This library provides two 'test's and two +'check's (in Schemeunit terminology): + +> (test-reduces reduction-relation term term) + + This check reduces its second argument according to the + reductions in the first argument, and compares it to the + final argument. It expects the reductions to only produce + a single result. + + It uses apply-reduction-rule* to do the reductions (as above). + + +> (check-reduces reduction-relation term term) + + The 'check' version of test-reduces. + +> (test-reduces/multiple reduction-relation term (listof term)) + + This check reduces its second argument according to the + reductions in the first argument, and compares the + results to the final argument. The reductions may produce + multiple results and those results are expected to be the + same as the list in the last argument. + + It uses apply-reduction-relation* to do the reductions (as above). + +> (check-reduces/multiple reduction-relation term (listof term)) + + The 'check' version of test-reduces/multiple. diff --git a/collects/redex/examples/arithmetic.ss b/collects/redex/examples/arithmetic.ss new file mode 100644 index 0000000000..f91a5baeb5 --- /dev/null +++ b/collects/redex/examples/arithmetic.ss @@ -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))))) diff --git a/collects/redex/examples/beginner.ss b/collects/redex/examples/beginner.ss new file mode 100644 index 0000000000..5819a08edf --- /dev/null +++ b/collects/redex/examples/beginner.ss @@ -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 ") + + ((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 ") + + ((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 ") + + ((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=?) + . 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 ") + + ((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 ") + + ;; 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 ") + + (test + '((/ 1 2 3)) + '(1/6)) + + (test + '((/ 1 2 0 3)) + "/: division by zero") + + (test + '((/ 1 "2" 3)) + "/: expects type ") + + (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 ") + (test '((symbol=? 'x 1)) + "symbol=?: expects argument of type ") + + (test '((cons 1 empty)) '((cons 1 empty))) + (test '((cons 1 2)) + "cons: second argument must be of type ") + (test '((+ (first (cons 1 2)) 2)) + "cons: second argument must be of type ") + (test '((+ (first (cons 1 empty)) 2)) + '(3)) + + (test + '((first (cons 1 empty))) + '(1)) + + (test + '((first 1)) + "first: expects argument of type ") + + (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 ") + + (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))) + diff --git a/collects/redex/examples/church.ss b/collects/redex/examples/church.ss new file mode 100644 index 0000000000..06af4f7fa7 --- /dev/null +++ b/collects/redex/examples/church.ss @@ -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))))) \ No newline at end of file diff --git a/collects/redex/examples/combinators.ss b/collects/redex/examples/combinators.ss new file mode 100644 index 0000000000..b4d25faac1 --- /dev/null +++ b/collects/redex/examples/combinators.ss @@ -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*)))) diff --git a/collects/redex/examples/compatible-closure.ss b/collects/redex/examples/compatible-closure.ss new file mode 100644 index 0000000000..1c949b082b --- /dev/null +++ b/collects/redex/examples/compatible-closure.ss @@ -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)))) diff --git a/collects/redex/examples/eta.ss b/collects/redex/examples/eta.ss new file mode 100644 index 0000000000..416f05fb26 --- /dev/null +++ b/collects/redex/examples/eta.ss @@ -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 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 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))) \ No newline at end of file diff --git a/collects/redex/examples/info.ss b/collects/redex/examples/info.ss new file mode 100644 index 0000000000..8e947b6c8e --- /dev/null +++ b/collects/redex/examples/info.ss @@ -0,0 +1,2 @@ +(module info (lib "infotab.ss" "setup") + (define name "Reduction Semantics examples")) diff --git a/collects/redex/examples/iswim.ss b/collects/redex/examples/iswim.ss new file mode 100644 index 0000000000..10498a284a --- /dev/null +++ b/collects/redex/examples/iswim.ss @@ -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?))) diff --git a/collects/redex/examples/letrec.ss b/collects/redex/examples/letrec.ss new file mode 100644 index 0000000000..0e728d3d61 --- /dev/null +++ b/collects/redex/examples/letrec.ss @@ -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)))) diff --git a/collects/redex/examples/omega.ss b/collects/redex/examples/omega.ss new file mode 100644 index 0000000000..ddda032efa --- /dev/null +++ b/collects/redex/examples/omega.ss @@ -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))) + ) diff --git a/collects/redex/examples/semaphores.ss b/collects/redex/examples/semaphores.ss new file mode 100644 index 0000000000..501c2397cb --- /dev/null +++ b/collects/redex/examples/semaphores.ss @@ -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))))))) diff --git a/collects/redex/examples/subject-reduction.ss b/collects/redex/examples/subject-reduction.ss new file mode 100644 index 0000000000..feaddcec6c --- /dev/null +++ b/collects/redex/examples/subject-reduction.ss @@ -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))))) diff --git a/collects/redex/examples/threads.ss b/collects/redex/examples/threads.ss new file mode 100644 index 0000000000..cd95315255 --- /dev/null +++ b/collects/redex/examples/threads.ss @@ -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))))) + ) diff --git a/collects/redex/examples/types.ss b/collects/redex/examples/types.ss new file mode 100644 index 0000000000..3f3e8a7753 --- /dev/null +++ b/collects/redex/examples/types.ss @@ -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)) + ) diff --git a/collects/redex/generator.ss b/collects/redex/generator.ss new file mode 100644 index 0000000000..7516a791fe --- /dev/null +++ b/collects/redex/generator.ss @@ -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))))) diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss new file mode 100644 index 0000000000..7dfb5151c9 --- /dev/null +++ b/collects/redex/gui.ss @@ -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) \ No newline at end of file diff --git a/collects/redex/info.ss b/collects/redex/info.ss new file mode 100644 index 0000000000..05a37dba0c --- /dev/null +++ b/collects/redex/info.ss @@ -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))) \ No newline at end of file diff --git a/collects/redex/pict.ss b/collects/redex/pict.ss new file mode 100644 index 0000000000..0ef7a4ee84 --- /dev/null +++ b/collects/redex/pict.ss @@ -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?)]) \ No newline at end of file diff --git a/collects/redex/private/arrow.ss b/collects/redex/private/arrow.ss new file mode 100644 index 0000000000..ccf71bf6ab --- /dev/null +++ b/collects/redex/private/arrow.ss @@ -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))))) diff --git a/collects/redex/private/bitmap-test-util.ss b/collects/redex/private/bitmap-test-util.ss new file mode 100644 index 0000000000..ac70a815a0 --- /dev/null +++ b/collects/redex/private/bitmap-test-util.ss @@ -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)) diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss new file mode 100644 index 0000000000..3a6de6adcd --- /dev/null +++ b/collects/redex/private/bitmap-test.ss @@ -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)) diff --git a/collects/redex/private/bmps/extended-language.png b/collects/redex/private/bmps/extended-language.png new file mode 100644 index 0000000000000000000000000000000000000000..117dcc482c84b17353d2bfcabbfb6a1d7e0c8224 GIT binary patch literal 2056 zcmV+j2>17iP)9}OUVpuLp6By9pU?B0v*US7 z001etPx^?TwWb#}WG6lA4`~LmAqod=@UQwshkw_$56K6K{&vWY3DTzcfOUc!0 zbz@^=ZEfv;3!knwqtRGUP+%|^ey+MHc>DJ4lP6DbJ@1ZcR&j7}xN+mg)2B~oFsI36 z;_-Nqk&!MgE;E=G$KT(7WMrhGq5}PCM@1%+WinYF(~{v}w~!B?N%;=g;rozkl-Jn>TOn z-Mcqammm-bzP`R!uU;jZv*+aG zX6A+s8?;*O*|TTqbh=8V8XFrsefqTd*5UDZm6eqWg(4{_DIy|5sZ=H=CI$rs0f0at zU@#c?k6vSAV{mY=P$=Z_cw4q?>Fw>cZXd(2tgNhnfPmMpUx$Wa)`t{Y-)tQ-@7=~%J+C_^NEm^XJ&1NHnR4UcYn>X2PHibeV5C}{r zv#zc#B_&0nP~5+NKPoC}@#4i=trj8l`0--`fk35F3knK6JUnjQx@FxynM|fqsZ1ub zySrN;5O6pg8?{L!lI6>n69@!^P;YN)_xZuIuXREJAGT_H?r}8ciaR zAf;02>FHThQFWIyyQm26yb(5f>My*Xv)te7SPvN_;RZEbPvm zI{=WLp1x+y8hp^l$0s>C*<>uvA$bhARCkW40{ z!oorZgHcmcGd@0U=WbrOaDipT_3PK|47ZK-b_@>>J32bHwzdMmrAwC*6B7YIuh+Y{ zxTsXBckkYDx!hyNjsZYlUmt-$5R1hCuxHPnjEoEbxO?|*XlN(^^z`(&yStB#jRAmM zE~ii^GMUV}eUr(wbm`KXni_j*lSm{)BGF(lOdc#OEDR0~p0YdJyFJ}(Wo0Fc#af7A z7==QKh=@Q4_4V~psZ=K?C-d{z-`_71iDF`6ChOSP*zMc5TRgdRI^ALQnb8X6jSJf2uA)@U>g27^c>wzs#d)#`+V zgr1(B=H_M&hr?pAj7FnSD7<|6G9Dft9xfJ(o0^(-?%e6@>})cbl9H10^YiI+x^?@V zot-2SY1gh@HcB$Hdi81&iS+gBS8s1`d)C|D?dfI}3WcAaA2B8-MlP2pBqWrTl_{0V z$&m=5+S=N*v@{F7YSpR`E39iRDJgmM=n+CltJU)Pe5q7wL))OPt}Ze%64(9x{hghi zR4R37Xh@+@ zg~E)CjFTr%;(xYTw_jghzi;0@BGInTm<088|k0{+SYfQgBT!NEaXV;E*T#QfG7A0IbInX%pe55X`jDk{qU^|mi( zJu8>X4<9}Z0O&uL_!l!>U0ub+#j}xFrBWR~eq68D0{{W$nO*yvGB7aU?Ck93<~Flw z#bPm&$y~T_Awp>09o2kx*5{Ua=K;=VXMJv&cSkj=%!af6%lNa7YBrqpU&dc&{kMVm z>eZ{jz(CxzZ*On6xa0mh>$aWsUkTCA&o3-2?8S>02%(J|H{xITX8tvIbNfcNj;dwF>Y z1OlVcXfZ97O3TX1EcAyDAKI*t%jFiad_KRtyc_^jD%FV-Cwh8%Y-lsqM^#l-#b&c{ z&Eaq!K782K)z#eG92gj=(P)Z`i$g*}9z1x^-Q8VKP!Jv-4gdy&flMZU{P+<7jvhUF z@#4jluIK9x$f*7m?=v*Y68004h`*VfkB&}OWU>d28J+1c5+_VMw_%F5Dc zG*wkq-rnBl&Yd$D3|?Mdd3kvlhH<&vqM{-IXlZF-u~>Krhr{9Vc%MFf5(oqb4jgD| zYC3b~4E~G)z?Uyy)~;O}A0J;@TH4mu1^^iu8A(Y=_P6=V_`k7aFc=&h9HxAk>GgWE z8$Vgk2^faqo)ZA5)#_!-mLY_OhlgEVU2TN8y1L^3Q`hNqBO@btlo<{aTtc0rb&{t+wF>?AQIz)ymh53JcQf6(ACH2?qr07*qoM6N<$f>ZLb2A2&@4NS}d)AtnwPt2L=bRnC*ntYqBnYljTtyIsKuS_n2|jp2P+-hbiv-$f9z zbScrN&)+1iCOf@QR-0-kG{L!)mR=eX=snj)Q_53SaXp>pW-A?`p<=}B+h~f z{JB5&L^|#Liy+Tt6l%a$^L^>1hceQN!MYMthXsBloS;s1l)CXh2-Q`S9|7qs9o=(PMF;hLnYVIvJ;_taM|bJtB02J@Q|0Ev%c1$1nV&EV zU+=mf%ds9+b>8Pit2T6Xhnk5r^pESro zoy^d3hI?mb#u$cD{Q>Icz4JR$N=_k~!w(g_FC$I)kZZW@awEMyozP zF;QpSM?Kn32gh{&xTpFL3kwSq(qFmoYK>9S#nZ3#~Z>BI(DP( z&uaQ?O4{011_m5%M+Xh*_u|>=zE8NF9Bf81$Z&9SPLBqlmE#=qj1Src&lHuFx0xl- z@y#7N!6L$2&f(QEZ0fXju?D4dOA`y*hn3dTL&L+yk8YEblRs1|w6L&vxBgD@9zLdb z^7r=~K3?9j@o}9hn^#9WzYPryFJHdAl}y}e@RWA%+R)GtQ_rnJo_Bc_8`S@DMZN6I3+VV0xE9>FG9M;F%+gCV^ za!G`(I=n1pW-wn(Lqh{ao2JmQv@NAV5V&$bh|J&DpsvHCQ3lTb-&?ZAc2VUzn3x2# z%v`&6tz%^T+qdwM8>8c2sio43@B4;@Y|tMs37+TX=O-p73pfkXAI5gBDTq7A%i+v7 z8WZi(2Zw}QyK?1lrL0eU^euK)=U%M{`ESF=m%=^Pf(|3#jPLZ|1vXMb;U4MT2200TcZ|mM-xy) zOGnq}7Zw!2R`2&@$phsL>!_(8}8#66X4_20zt$11Dk+Nj-NwscnZn$2aZ{m`Y3UYEP-A|nX zP#|?7c$p~~5if3u|D@{o(Ga&d7HV1SW<;kAPU93T>& zbLDVU>eTDQ-O;MqD|gJigdTBo2XxW%yo=B_QYM5FL*7M4GoaCRPW(}w{Fr%EM0*B} z3p%hl{XRv<=23)HXzXNK$PQZ~Zn(PvI_l=zZxM2+$;n9`9-adoPsuYu8V{yk(akBB zbukHvTV!NkUFgv30l87NfPQjva*15lG5eyDQ#X_u9o7FO^J#ifX_Z{ZD7+OGZnuW1 zo>0ztcDh^Sv0%f^_$=u~u`W(j=gRuJp!*5;W_uyPxv8n?>guYyyE{P7^2*B2=B9eN z*-gaP-=9UNfpVP$gTV|HsEcIuySlk?S&S&Csre@ce{HYQTx&erWwEo{HttJtJDBkY zyv6X@MRGwp@*!P?g;sicn5Eui*x$BV^SVE~-J&cL6B9l@zAsT!XGmyhd2#W#@86Y` zl-StVzIJqQJMWmdxEy<&ZQs3h>lOh4!F7KhqOV`SDk&+YE8LHWhyc7gSl4Zx*N1zP zUTy8@2x!uUQ${f>MNu5Cle4k2<9r?*EU&9`-CG$AzQrPr>Nnx2vm>~2B~9UeFd0*G zL`zGH%l=wVR~N)AB`Yf{FYgaj?URF_7c`IiCGLLItR|-A;OB>WWmI`0p3%RN%meoW zeCycmmYNE8bfW(!0G^=cy+S~Dv%XoN$gM;z1Mz3F&`}nk^ ziTES$8yd8wq;l)(C=rLX38$@jDWuA2d(r={I|{jZ^XAyt*y-sh@@--Qb{zikgOr4% z40;-lxcP>kKS_utj@`Jo-erGkK|QLDVg95cF)FG|uQh0Qd6?d}w5$x$*45SZ+x}>4 zp({E%IygAEwzk&N((>Vh2W!)f*5>B5daYNVq{?UX*VWhC+VSz#Zf$LKcXxk$S=k%M zDndhaaCoRyV{h8zeJOIQBr=kilatfM#pN)Cv(uMmX`-j2!^Xj(ZK18LZD2s@>f2_c zvhnfp#`7~5XoKwR?6x-X2hm5{eS)<$HFUne?2o)J;eUAkK=?yiT3UJeYe)iQ4?@mC zu{z%wmFjWEbM`bb({*Jj)x!aUQBsXLe-=33qev=nK{%jmVRpO~`8GKz;JBvgs~|7m zSD;=dZpvmp^zRADdtm6PDeZ|M1R1daB;R|P!WT%X@P2}Umi*Ry4r8am+wMt0n)-oz zRL}#{3KHVZS#rGD&(<0UsK|duXLraZPq^LTWgB=X7ZD#f5sJk!X0oR*IClCjcX;kd zD_a=!OoAc-P(R!GE{{r^oz*L; znbkld8Rb)Gd_i?=STcD>KU6z9J`Rq?Qt_$M;WWg`yzltWj{Ol@N8t$xe}4T!A@;nd zGcEokSs#i^N=AXw0EgBa&#iQIJqfL*>UbC!E+M!VE}Wk%3C{V*#4-!G9uy1FRJk6O z#>cCRh=@2kRzk%BH6fnDX}*4bvyymt{u>(`y}i%0v?if!-oAZ%cznFSyNlxqYN5h% z9B6BV1N~aqac!c%zn_*`Tuh9df&y1aRMZz5YCbTa^@5PFaI+u59Z~Ez6AnO=etIRw ze>fvWLu^kv5~Z^mTn{5#W_}D0lkoW}a=YxUgx=x$a{cJ=kc!*J^UVmzztq3=_5AsB zfQbsL$si&M3X1gazqza?KIG=UdUV^t!2y-F)RzjB`!~2y5$fvdVPRoF(EvPfm!Thj zbsHd3`#mmz2Q0NfP)G=AIjyp?vIy$R+h(ZOgM&A-llG*jb@mhGH;P3Z9vJ2~+Lw-OIV ztWGyJrl-#Wji&RK1_Yqc>GWMaJyc>6enfdiML7!h0VPV8J5cLohucf~MI3c1G<5@T zUeR-+XB^b0MQR$7l9FO#tuE{Jl?I)}9C>OKtWp*{V$NBio!kw^-v$OWs%&O*Qr&qi z$2dyzc6N63+rt8*0o{hBJyX?i|65W)y;TmkA;I)21lO)fGId>_s=)PBxWDq}PqQI& zET1!p-qP2(%>dPlk&g}LyrE(ZNSm>;5w!IKq-07Lcphh}CFlt+GItsnVwTCpon|%< zPiALltE#vaeLQ>>WMpJiRbzhK(Z_i87y*9-xkc|S%C1&s#R36b!MKsmYajrY$*i=rsLsam z;aO=4CWeNbCEJHZVoF*%|OG> zuB=2H4{~Y7-Q~iC3-C9ivQf6S;laVx@k&CEXqk+D0CS%!jcj)I_U|(KN=CfnV8zGF z>7F0Nt58dAqQyZDM@J9Fvl|DLnyi{HcZf&kOg6aj(b3T{Fl zJTmfv@_e>67$^+t;L_#Gvv)}Nsf&t>!=5&p-dr(0Fz&?CtFx9UK@K7|bs%$vm(+bUmw_b_e%FK}O~P zM#ERZ)HF9LDoTh(Qc9|6yQHK91kXr`emmHTK)=BMEXaY&&M!qv%T?&@XGz=*Px224IJE*gPQpH=y*xR-~ET%4U}XTmvpD4t45fxYQz z4ZgL#wN>!(V_z~~y8#;^HNT04g=_&fj#(ZPEqcqhWybaVbRYi~Go|USxVmwt(^R9! zdF^^bt;6aV5D=I3)Jgk(t+uvyN=nLzwkdkx`}bQ+8opgR?uQF;I*qLH-IuQfu&iDQ zqv9hYCB29Ur`b$5xFJNqaUSRHt_F+U@c=gm?-LWp0aH@=oxER1nwgnZ|5H#@obrSp{}m-{JFio zJ$Txy7ja7hlLbAdy1E`dd6Lq%WNvCYI5hMh$ji@vc-;nrsd3(YfP86dCzIg+ojBeG#`8@RTWyt^v0pT7Q8M!u9pO}~^Bk78Zi_5H8g&=@w5H19H z`Enc(9GGKqejX7rGs~;57eG$-#;rl101YGIad9uSv>i?>OrM9(Y zMSj-)^6~LuWn~2k7HJ3OrV%7Ecx}M2v$Oq1omz*FH8mO{A{UCV26nmm=o%U*B*4oy z!`ytva=cD2Vq#(l(54i84NmYRqBb&!F}KebbeD?CO>Fz$JpF1arN1W+YOH^7uyua~ z1oA+ZjBQ-p*+Y7I{nntH2n`VmuIj&i0Xf@>ZG0CKgDWH?^cf<(8Pwk1K34{kV!Yap zG3;bMN*-<>85KoH#rs@U)z5qrzaBaw^U6eufJ=5-TK~jEh|41mj=DFSbVyZIm1Z^O z5(47hhEP#a5wQU+07;(xDS@S?^#!Zu#Gm5lcex=#RZT4?JKJHYmkQx_KRM{nkiemV zHXJQA1S)IC-o*w6;&?VSJtZIrgR$+7n=>{0RbaI1_o#ZumuvW zqN+OE0UOoS*3Ok?8p&BSL)*fv;`i_0h%R)^+#Ed-Dm^0uW)qo@V{4?-@o^ETV8|e~ z;V#-GoDyYx$$jB`tBWNjCPrvN4WEz@u!V}fZ(?#1wzZyam>eJHGXit4arKJ($)-ff zBi>}ISFf6k$~IllWC=45tgY95@Cdy*?v}Lp6T-v-SIFJ{EQ!a?CJeBmH<62Qsj{SG zbF$Xawm39Y&fcB_sj9994R+i=R0Qy%PHL2A?8%sm>OZy<5%L2r%@ z4({d`HQ*-IiUA848a{sz-K6{D#}5SYX)-Y}LH-7?U8~jsehQ?rHZhTumL`5E=y6sj zi92h^SX1S3^gXq?rDap%P~xte{oaZ?($Uicoc;_*s;KCEcUT8x1{ zC7pWbK~T{MG`8dF7+|8Nj?OfQ>+EblzB=dKJb!;YtE`L+Wl$g*8b`CO_=biHpq-Fk z>+2q8C)FbbFc~p?^~$RYG$yDs=7$gQuU~IVBuBXIe|>}L4UXrtoIB*?oE#jIdEByc za+?}pY=B))Om7nrZNP!%_Qe<(8I#C>+yDZosHk8PVm?&RBrwN_%eA?^O|nXUex2Hy z@j4~<&(&4A`6D$Qx7|_WRDcAq0|L%FC?t%M2eUH5il7JxPRFOu{92%V(TsJrbK)n@ zJRpgj=0gZbgCssjW}l`Hd3li*%&!5i=V1!s?ChMJoD9ZMNlo62F!I9a=;$RpybGV9 z63ah*x_b30!0WrL2Pw_X&0u+h(2qDd7ckW?D=cpCosIFbp=sr}H#P!7Lr-UeSz!1E zi(1gVAR~i5_gt^!1vDg>uBj=QqPZXa&ViOPA1*Xxi|41tb}dlczWwd@PFE~T+31SL z`SCO=4J11N8yI^AnHYuK9|A6W+`PQn)ffhPdXXJ}f!n#bTp;ob3t{w7@ZrOKbMs~B zn^|)fNXg!wgD|c*5h>};^!Zt=cn0j8m7T5UGBhwS0H|@I9uXV6^z)}DQC?wT3a7cM zyF2XE(Aek!RRyhy!LT)yxSpT6fs5=9U{opUsCE%F#X+f1Bv*e#VCVN2 z|B|J2-lt>hm+Jzpkl539N|ee5!?&y~v6cNBdTK!jTUN3tuf!j!xL)sba*Q)8z(eWz z?CtDGYTs%;7Z?S?WgQNGQ~HI@-_Oqmrcp&;Jnr1NBWA86@`91~Trq(pA6-GCH{PW< zq-mebfJc|@1T9kb(%0*C%pu$B^ z5fMc}P-AjKNU*e+P_z#!Ql{FZHSc10Mbgy!-gxhY`&&Kp%>SJKdCr+L=g>%!1ONcQ zaopqal$MrqI2`!@K$4`##&jYgxCb$ zl5A*bsHmu5GMR&egWqfOpM?$p^YimvU0w6@^9qH6%jGsTHJMDN=*Cbse*9QnT?GKM*<4do6TRp2^K-pkuh;8GM@QqV0mCqU7}eF) z@mSCSfXn4hPEKB5Uz<#(p`oGU<71^#iD6h2O9VmGYIR**-T3%8f*@9_RU{HcR7$1N znwlDm#R32_nM^1YM(K8MZ*O2=K&R93c)XjNn>cC*04OUf`zws)<>h!R=q{JbU@&}q zd>{x?RaG@IGU9MJI2_Jb?L$FP6vy$}+S=%{^73+<%?1Ewv$?ag^DEiI!$VtJTYrDQ z!C9F$ASWj$9UUE?l47x#+H}z^5Q#)0 zl}h{i`c_s}a&vS2e!tOZJUl$??d^^3YBHHn6xHkXXJ=fPPl;^LxKtEDm#l>|Wu1cLhddH}$2JS!_JAt522`o&`L+}zx!Wbil(CENl? zlC<0Ha=9D;Qc_Y_ELKrb(Zs|=@PrIM|M&OzWir|B?k-7^I-O3fR@?1%k|YfV12xB= z&e;3=d%0Zx{QMluL{#41-sa`yX*8Opr6ml*g87z~7V6p)41Sw%3j_cP3JNd`b2^gs$e{gURy3`Ss0)gP- z;==3orlh3Av+Tb?xCK4FLSga9mwoy}rIu!QZYpj87J{nD;!p-TwUi3;;|f)9?2K zKw)7ao6Y{`Ly3vU7Xs%+F3^a&>F(NfqH!dux6sZX8qPi*2p-&B;KIifG?7ZjU_+3xpPgIN$>gwv+wrv}ZED zq5l4Uy4rM`zYidU?%lhm)oO`ja*PlP27`P)U$58G)kpbJ;5e>OD87CBmT(>EFcU)D z9PtDk$G2?RGBq_toH!B_5Vvt{Z7tnGqkJk&O-*fWZON=P9cDt}H;CzWyB!XPSS$tr za!kU06>lb0K>3Hj~-pS zcCDU3n+}tl; zz7R>ODUnDjD=Xi~zh23sHbm&kdBM=CDJ|Efn`t_??t-f&KLT6{E*=%lYZKX2-Kq{4* z&1L|Yn3$-mtBYd-0AodvYoohUTwLt+dPAWQ0FYw<=J3gPUprC-985$bO&CLaXvuDq?x3{ley_(Jh0Fg-KbUGIo7wvZYfddEP zn2>0TrQ3JNh0)z9Dk|dfc(b#!06>n-X7igjZ%&>(2>|)|`Bha_TCFw^2#|}(J^&bv zMukGb<#IoM{21wx$K#PmB;+a#!-PWNkt0WVJf7WdUtV6OGXY@z`t=@*V585Ffc$gFA_I5H%q0`NK@aweY}srBcn#&N`h=l}g3sa?8uhGjQskAcQI^ zDvlpN9+~U9y1G~_mepz{4&`$B@bEA>$S^fEHFxgZAqN?Q4FD#SsiC1^&6+htzcd;R zhG8hqQ$S{kJjKR&KU>gsBv(HOssZX%~bH)qp9o!$Q+OaREq$!TwIce~w2qw&(EORrzQK6vn; z!C;6}MmLdDp_{W~5_5L{gD@QqM`vdzj^k`Ld+*-8H*VapTCG`GS$%zd35%%{c}!x? z*;MFe_df_5!?1Jb&dFplsZ>g&_j`$8i7{9v-f*uOAs1 ziSo0vv&CX@U0ofE#Ue5>%@Ze1xLmH&r%(6w_07%Aty;Az)ffA(VFSSS?b{6o!}RpD z!{I0?DG>++@oN+c#nY!xv$L}SprfNB6bcdV`5GD;3JMCS`>sGBc=6%|hr@|vVwyss z&}OqOEG*>Z<)!4>ejjEeDl9ClsHlk9npdx0O-@eYI8FqCK!9is05F-%$SY8<*Nb6T zX=y3-6UeQJV=@>Fa%+4(pVeyp{Q0xr? (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))) diff --git a/collects/redex/private/core-layout-test.ss b/collects/redex/private/core-layout-test.ss new file mode 100644 index 0000000000..8ec73295df --- /dev/null +++ b/collects/redex/private/core-layout-test.ss @@ -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")) diff --git a/collects/redex/private/core-layout.ss b/collects/redex/private/core-layout.ss new file mode 100644 index 0000000000..848b4585a8 --- /dev/null +++ b/collects/redex/private/core-layout.ss @@ -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) + + ) diff --git a/collects/redex/private/dot.ss b/collects/redex/private/dot.ss new file mode 100644 index 0000000000..b7e594eaed --- /dev/null +++ b/collects/redex/private/dot.ss @@ -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)) diff --git a/collects/redex/private/info.ss b/collects/redex/private/info.ss new file mode 100644 index 0000000000..7591fe36a2 --- /dev/null +++ b/collects/redex/private/info.ss @@ -0,0 +1,2 @@ +(module info (lib "infotab.ss" "setup") + (define name "PLT Redex private")) diff --git a/collects/redex/private/loc-wrapper.ss b/collects/redex/private/loc-wrapper.ss new file mode 100644 index 0000000000..c2b04deb77 --- /dev/null +++ b/collects/redex/private/loc-wrapper.ss @@ -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)) diff --git a/collects/redex/private/lw-test-util.ss b/collects/redex/private/lw-test-util.ss new file mode 100644 index 0000000000..0b6b7a2980 --- /dev/null +++ b/collects/redex/private/lw-test-util.ss @@ -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))) \ No newline at end of file diff --git a/collects/redex/private/lw-test.ss b/collects/redex/private/lw-test.ss new file mode 100644 index 0000000000..2ad176bb96 --- /dev/null +++ b/collects/redex/private/lw-test.ss @@ -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")) + diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss new file mode 100644 index 0000000000..c0775b7f83 --- /dev/null +++ b/collects/redex/private/matcher-test.ss @@ -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)) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss new file mode 100644 index 0000000000..a87f14f5a0 --- /dev/null +++ b/collects/redex/private/matcher.ss @@ -0,0 +1,1647 @@ +#| + +Note: the patterns described in the doc.txt file are +slightly different than the patterns processed here. +The difference is in the form of the side-condition +expressions. Here they are procedures that accept +binding structures, instead of expressions. The +reduction (And other) macros do this transformation +before the pattern compiler is invoked. + +|# +(module matcher mzscheme + (require (lib "list.ss") + (lib "match.ss") + (lib "etc.ss") + (lib "contract.ss") + "underscore-allowed.ss") + + (define-struct compiled-pattern (cp)) + + (define count 0) + + ;; lang = (listof nt) + ;; nt = (make-nt sym (listof rhs)) + ;; rhs = (make-rhs single-pattern (listof var-info??)) + ;; single-pattern = sexp + (define-struct nt (name rhs) (make-inspector)) + (define-struct rhs (pattern var-info) (make-inspector)) + + ;; var = (make-var sym sexp) + ;; patterns are sexps with `var's embedded + ;; in them. It means to match the + ;; embedded sexp and return that binding + + ;; bindings = (make-bindings (listof rib)) + ;; rib = (make-bind sym sexp) + ;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer + ;; NOTE: the bindings may contain mismatch-ribs temporarily, but they are all removed + ;; by merge-multiples/remove, a helper function called from match-pattern + (define-values (make-bindings bindings-table bindings?) + (let () + (define-struct bindings (table) (make-inspector)) ;; for testing, add inspector + (values (lambda (table) + (unless (and (list? table) + (andmap (λ (x) (or (bind? x) (mismatch-bind? x))) table)) + (error 'make-bindings "expected <(listof (union rib mismatch-rib))>, got ~e" table)) + (make-bindings table)) + bindings-table + bindings?))) + + (define-struct bind (name exp) (make-inspector)) ;; for testing, add inspector + (define-struct mismatch-bind (name exp) (make-inspector)) ;; for testing, add inspector + + ;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean) + (define-struct repeat (pat empty-bindings suffix mismatch?) (make-inspector)) ;; inspector for tests below + + ;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch)) + ;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole])) + ;; mtch is short for "match" + (define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?) + (let () + (define-struct mtch (bindings context hole) (make-inspector)) + (values mtch-bindings + mtch-context + mtch-hole + (lambda (a b c) + (unless (bindings? a) + (error 'make-mtch "expected bindings for first agument, got ~e" a)) + (make-mtch a b c)) + mtch?))) + + ;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole + (define none + (let () + (define-struct none ()) + (make-none))) + (define (none? x) (eq? x none)) + + ;; compiled-lang : (make-compiled-lang (listof nt) + ;; hash-table[sym -o> compiled-pattern] + ;; hash-table[sym -o> compiled-pattern] + ;; hash-table[sym -o> compiled-pattern] + ;; hash-table[sym -o> boolean]) + ;; hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)] + ;; hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)] + ;; pict-builder + ;; (listof symbol) + ;; (listof (listof symbol))) -- keeps track of `primary' non-terminals + ;; hole-info = (union #f none symbol) + ;; #f means we're not in a `in-hole' context + ;; none means we're looking for a normal hole + ;; symbol means we're looking for a named hole named by the symbol + + (define-struct compiled-lang (lang ht list-ht across-ht across-list-ht has-hole-ht + cache bind-names-cache pict-builder literals + nt-map)) + + ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any + (define lookup-binding + (opt-lambda (bindings + sym + [fail (lambda () (error 'lookup-binding "didn't find ~e in ~e" sym bindings))]) + (let loop ([ribs (bindings-table bindings)]) + (cond + [(null? ribs) (fail)] + [else + (let ([rib (car ribs)]) + (if (and (bind? rib) (equal? (bind-name rib) sym)) + (bind-exp rib) + (loop (cdr ribs))))])))) + + ;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang + (define (compile-language pict-info lang nt-map) + (let* ([clang-ht (make-hash-table)] + [clang-list-ht (make-hash-table)] + [across-ht (make-hash-table)] + [across-list-ht (make-hash-table)] + [has-hole-ht (build-has-hole-ht lang)] + [cache (make-hash-table 'equal)] + [bind-names-cache (make-hash-table 'equal)] + [literals (extract-literals lang)] + [clang (make-compiled-lang lang clang-ht clang-list-ht + across-ht across-list-ht + has-hole-ht + cache bind-names-cache + pict-info + literals + nt-map)] + [non-list-nt-table (build-non-list-nt-label lang)] + [list-nt-table (build-list-nt-label lang)] + [do-compilation + (lambda (ht list-ht lang prefix-cross?) + (for-each + (lambda (nt) + (for-each + (lambda (rhs) + (let-values ([(compiled-pattern has-hole?) + (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross? #f)]) + (let ([add-to-ht + (lambda (ht) + (hash-table-put! + ht + (nt-name nt) + (cons compiled-pattern (hash-table-get ht (nt-name nt)))))]) + (when (may-be-non-list-pattern? (rhs-pattern rhs) + non-list-nt-table) + (add-to-ht ht)) + (when (may-be-list-pattern? (rhs-pattern rhs) + list-nt-table) + (add-to-ht list-ht))))) + (nt-rhs nt))) + lang))] + [init-ht + (lambda (ht) + (for-each (lambda (nt) (hash-table-put! ht (nt-name nt) null)) + lang))]) + + (init-ht clang-ht) + (init-ht clang-list-ht) + + (hash-table-for-each + clang-ht + (lambda (nt rhs) + (when (has-underscore? nt) + (error 'compile-language "cannot use underscore in nonterminal name, ~s" nt)))) + + (let ([compatible-context-language + (build-compatible-context-language clang-ht lang)]) + (for-each (lambda (nt) + (hash-table-put! across-ht (nt-name nt) null) + (hash-table-put! across-list-ht (nt-name nt) null)) + compatible-context-language) + (do-compilation clang-ht clang-list-ht lang #t) + (do-compilation across-ht across-list-ht compatible-context-language #f) + clang))) + + ;; extract-literals : (listof nt) -> (listof symbol) + (define (extract-literals nts) + (let ([literals-ht (make-hash-table)] + [nt-names (map nt-name nts)]) + (for-each (λ (nt) + (for-each (λ (rhs) (extract-literals/pat nt-names (rhs-pattern rhs) literals-ht)) + (nt-rhs nt))) + nts) + (hash-table-map literals-ht (λ (x y) x)))) + + ;; extract-literals/pat : (listof sym) pattern ht -> void + ;; inserts the literals mentioned in pat into ht + (define (extract-literals/pat nts pat ht) + (let loop ([pat pat]) + (match pat + [`any (void)] + [`number (void)] + [`string (void)] + [`variable (void)] + [`(variable-except ,s ...) (void)] + [`(variable-prefix ,s) (void)] + [`variable-not-otherwise-mentioned (void)] + [`hole (void)] + [`(hole ,s) (void)] + [(? symbol? s) + (unless (regexp-match #rx"_" (symbol->string s)) + (unless (regexp-match #rx"^\\.\\.\\." (symbol->string s)) + (unless (memq s nts) + (hash-table-put! ht s #t))))] + [`(name ,name ,pat) (loop pat)] + [`(in-hole ,p1 ,p2) + (loop p1) + (loop p2)] + [`(hide-hole ,p) (loop p)] + [`(in-named-hole ,s ,p1 ,p2) + (loop p1) + (loop p2)] + [`(side-condition ,p ,g) + (loop p)] + [`(cross ,s) (void)] + [_ + (let l-loop ([l-pat pat]) + (when (pair? l-pat) + (loop (car l-pat)) + (l-loop (cdr l-pat))))]))) + + ; build-has-hole-ht : (listof nt) -> hash-table[symbol -o> boolean] + ; produces a map of nonterminal -> whether that nonterminal could produce a hole + (define (build-has-hole-ht lang) + (build-nt-property + lang + (lambda (pattern recur) + (match pattern + [`any #f] + [`number #f] + [`string #f] + [`variable #f] + [`(variable-except ,@(vars ...)) #f] + [`(variable-prefix ,var) #f] + [`variable-not-otherwise-mentioned #f] + [`hole #t] + [`(hole ,(? symbol? hole-name)) #t] + [(? string?) #f] + [(? symbol?) + ;; cannot be a non-terminal, otherwise this function isn't called + #f] + [`(name ,name ,pat) + (recur pat)] + [`(in-hole ,context ,contractum) + (recur contractum)] + [`(hide-hole ,arg) #f] + [`(in-named-hole ,hole-name ,context ,contractum) + (recur contractum)] + [`(side-condition ,pat ,condition) + (recur pat)] + [(? list?) + (ormap recur pattern)] + [else #f])) + #t + (lambda (lst) (ormap values lst)))) + + ;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean + ;; -> hash-table[symbol[nt] -> boolean] + (define (build-nt-property lang test-rhs conservative-answer combine-rhss) + (let ([ht (make-hash-table)] + [rhs-ht (make-hash-table)]) + (for-each + (lambda (nt) + (hash-table-put! rhs-ht (nt-name nt) (nt-rhs nt)) + (hash-table-put! ht (nt-name nt) 'unknown)) + lang) + (let () + (define (check-nt nt-sym) + (let ([current (hash-table-get ht nt-sym)]) + (case current + [(unknown) + (hash-table-put! ht nt-sym 'computing) + (let ([answer (combine-rhss + (map (lambda (x) (check-rhs (rhs-pattern x))) + (hash-table-get rhs-ht nt-sym)))]) + (hash-table-put! ht nt-sym answer) + answer)] + [(computing) conservative-answer] + [else current]))) + (define (check-rhs rhs) + (cond + [(hash-table-maps? ht rhs) + (check-nt rhs)] + [else (test-rhs rhs check-rhs)])) + (for-each (lambda (nt) (check-nt (nt-name nt))) + lang) + ht))) + + ;; build-compatible-context-language : lang -> lang + (define (build-compatible-context-language clang-ht lang) + (apply + append + (map + (lambda (nt1) + (map + (lambda (nt2) + (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)]) + (if (eq? (nt-name nt1) (nt-name nt2)) + (make-nt (nt-name compat-nt) + (cons + (make-rhs 'hole '()) + (nt-rhs compat-nt))) + compat-nt))) + lang)) + lang))) + + ;; build-compatible-contexts : clang-ht prefix nt -> nt + ;; constructs the compatible closure evaluation context from nt. + (define (build-compatible-contexts/nt clang-ht prefix nt) + (make-nt + (symbol-append prefix '- (nt-name nt)) + (apply append + (map + (lambda (rhs) + (let-values ([(maker count) (build-compatible-context-maker clang-ht + (rhs-pattern rhs) + prefix)]) + (let loop ([i count]) + (cond + [(zero? i) null] + [else (let ([nts (build-across-nts (nt-name nt) count (- i 1))]) + (cons (make-rhs (maker (box nts)) '()) + (loop (- i 1))))])))) + (nt-rhs nt))))) + + (define (symbol-append . args) + (string->symbol (apply string-append (map symbol->string args)))) + + ;; build-across-nts : symbol number number -> (listof pattern) + (define (build-across-nts nt count i) + (let loop ([j count]) + (cond + [(zero? j) null] + [else + (cons (= i (- j 1)) + (loop (- j 1)))]))) + + ;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number) + ;; when the result function is applied, it takes each element + ;; of the of the boxed list and plugs them into the places where + ;; the nt corresponding from this rhs appeared in the original pattern. + ;; The number result is the number of times that the nt appeared in the pattern. + (define (build-compatible-context-maker clang-ht pattern prefix) + (let ([count 0]) + (values + (let loop ([pattern pattern]) + (match pattern + [`any (lambda (l) 'any)] + [`number (lambda (l) 'number)] + [`string (lambda (l) 'string)] + [`variable (lambda (l) 'variable)] + [`(variable-except ,@(vars ...)) (lambda (l) pattern)] + [`(variable-prefix ,var) (lambda (l) pattern)] + [`variable-not-otherwise-mentioned (λ (l) pattern)] + [`hole (lambda (l) 'hole)] + [`(hole ,(? symbol? hole-name)) (lambda (l) `(hole ,hole-name))] + [(? string?) (lambda (l) pattern)] + [(? symbol?) + (cond + [(hash-table-get clang-ht pattern #f) + (set! count (+ count 1)) + (lambda (l) + (let ([fst (car (unbox l))]) + (set-box! l (cdr (unbox l))) + (if fst + `(cross ,(symbol-append prefix '- pattern)) + pattern)))] + [else + (lambda (l) pattern)])] + [`(name ,name ,pat) + (let ([patf (loop pat)]) + (lambda (l) + `(name ,name ,(patf l))))] + [`(in-hole ,context ,contractum) + (let ([match-context (loop context)] + [match-contractum (loop contractum)]) + (lambda (l) + `(in-hole ,(match-context l) + ,(match-contractum l))))] + [`(hide-hole ,p) + (let ([m (loop p)]) + (lambda (l) + `(hide-hole ,(m l))))] + [`(in-named-hole ,hole-name ,context ,contractum) + (let ([match-context (loop context)] + [match-contractum (loop contractum)]) + (lambda (l) + `(in-named-hole ,hole-name + ,(match-context l) + ,(match-contractum l))))] + [`(side-condition ,pat ,condition) + (let ([patf (loop pat)]) + (lambda (l) + `(side-condition ,(patf l) ,condition)))] + [(? list?) + (let ([f/pats + (let l-loop ([pattern pattern]) + (cond + [(null? pattern) null] + [(null? (cdr pattern)) + (list (vector (loop (car pattern)) + #f + #f))] + [(eq? (cadr pattern) '...) + (cons (vector (loop (car pattern)) + #t + (car pattern)) + (l-loop (cddr pattern)))] + [else + (cons (vector (loop (car pattern)) + #f + #f) + (l-loop (cdr pattern)))]))]) + (lambda (l) + (let loop ([f/pats f/pats]) + (cond + [(null? f/pats) null] + [else + (let ([f/pat (car f/pats)]) + (cond + [(vector-ref f/pat 1) + (let ([new ((vector-ref f/pat 0) l)] + [pat (vector-ref f/pat 2)]) + (if (equal? new pat) + (list* pat + '... + (loop (cdr f/pats))) + (list* (vector-ref f/pat 2) + '... + new + (vector-ref f/pat 2) + '... + (loop (cdr f/pats)))))] + [else + (cons ((vector-ref f/pat 0) l) + (loop (cdr f/pats)))]))]))))] + [else + (lambda (l) pattern)])) + count))) + + ;; build-list-nt-label : lang -> hash-table[symbol -o> boolean] + (define (build-list-nt-label lang) + (build-nt-property + lang + (lambda (pattern recur) + (may-be-list-pattern?/internal pattern + (lambda (sym) #f) + recur)) + #t + (lambda (lst) (ormap values lst)))) + + (define (may-be-list-pattern? pattern list-nt-table) + (let loop ([pattern pattern]) + (may-be-list-pattern?/internal + pattern + (lambda (sym) + (hash-table-get list-nt-table (symbol->nt sym) #t)) + loop))) + + (define (may-be-list-pattern?/internal pattern handle-symbol recur) + (match pattern + [`any #t] + [`number #f] + [`string #f] + [`variable #f] + [`(variable-except ,@(vars ...)) #f] + [`variable-not-otherwise-mentioned #f] + [`(variable-prefix ,var) #f] + [`hole #t] + [`(hole ,(? symbol? hole-name)) #t] + [(? string?) #f] + [(? symbol?) + (handle-symbol pattern)] + [`(name ,name ,pat) + (recur pat)] + [`(in-hole ,context ,contractum) + (recur context)] + [`(hide-hole ,p) + (recur p)] + [`(in-named-hole ,hole-name ,context ,contractum) + (recur context)] + [`(side-condition ,pat ,condition) + (recur pat)] + [(? list?) + #t] + [else + ;; is this right?! + (or (null? pattern) (pair? pattern))])) + + + ;; build-non-list-nt-label : lang -> hash-table[symbol -o> boolean] + (define (build-non-list-nt-label lang) + (build-nt-property + lang + (lambda (pattern recur) + (may-be-non-list-pattern?/internal pattern + (lambda (sym) #t) + recur)) + #t + (lambda (lst) (ormap values lst)))) + + (define (may-be-non-list-pattern? pattern non-list-nt-table) + (let loop ([pattern pattern]) + (may-be-non-list-pattern?/internal + pattern + (lambda (sym) + (hash-table-get non-list-nt-table (symbol->nt sym) #t)) + loop))) + + (define (may-be-non-list-pattern?/internal pattern handle-sym recur) + (match pattern + [`any #t] + [`number #t] + [`string #t] + [`variable #t] + [`(variable-except ,@(vars ...)) #t] + [`variable-not-otherwise-mentioned #t] + [`(variable-prefix ,prefix) #t] + [`hole #t] + [`(hole ,(? symbol? hole-name)) #t] + [(? string?) #t] + [(? symbol?) (handle-sym pattern)] + [`(name ,name ,pat) + (recur pat)] + [`(in-hole ,context ,contractum) + (recur context)] + [`(hide-hole ,p) + (recur p)] + [`(in-named-hole ,hole-name ,context ,contractum) + (recur context)] + [`(side-condition ,pat ,condition) + (recur pat)] + [(? list?) + #f] + [else + ;; is this right?! + (not (or (null? pattern) (pair? pattern)))])) + + ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings)) + (define (match-pattern compiled-pattern exp) + (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)]) + (and results + (let ([filtered (filter-multiples results)]) + (and (not (null? filtered)) + filtered))))) + + ;; filter-multiples : (listof mtch) -> (listof mtch) + (define (filter-multiples matches) + (let loop ([matches matches] + [acc null]) + (cond + [(null? matches) acc] + [else + (let ([merged (merge-multiples/remove (car matches))]) + (if merged + (loop (cdr matches) (cons merged acc)) + (loop (cdr matches) acc)))]))) + + ;; merge-multiples/remove : bindings -> (union #f bindings) + ;; returns #f if all duplicate bindings don't bind the same thing + ;; returns a new bindings + (define (merge-multiples/remove match) + (let/ec fail + (let ( + ;; match-ht : sym -o> sexp + [match-ht (make-hash-table 'equal)] + + ;; mismatch-ht : sym -o> hash-table[sexp -o> #t] + [mismatch-ht (make-hash-table 'equal)] + + [ribs (bindings-table (mtch-bindings match))]) + (for-each + (lambda (rib) + (cond + [(bind? rib) + (let ([name (bind-name rib)] + [exp (bind-exp rib)]) + (let ([previous-exp (hash-table-get match-ht name uniq)]) + (cond + [(eq? previous-exp uniq) + (hash-table-put! match-ht name exp)] + [else + (unless (equal? exp previous-exp) + (fail #f))])))] + [(mismatch-bind? rib) + (let* ([name (mismatch-bind-name rib)] + [exp (mismatch-bind-exp rib)] + [priors (hash-table-get mismatch-ht name uniq)]) + (when (eq? priors uniq) + (let ([table (make-hash-table 'equal)]) + (hash-table-put! mismatch-ht name table) + (set! priors table))) + (when (hash-table-get priors exp #f) + (fail #f)) + (hash-table-put! priors exp #t))])) + ribs) + (make-mtch + (make-bindings (hash-table-map match-ht make-bind)) + (mtch-context match) + (mtch-hole match))))) + + ;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern + (define compile-pattern + (opt-lambda (clang pattern bind-names?) + (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)]) + (make-compiled-pattern pattern)))) + + ;; name-to-key/binding : hash-table[symbol -o> key-wrap] + (define name-to-key/binding (make-hash-table)) + (define-struct key-wrap (sym) (make-inspector)) + + ;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean) + (define (compile-pattern/cross? clang pattern prefix-cross? bind-names?) + (define clang-ht (compiled-lang-ht clang)) + (define clang-list-ht (compiled-lang-list-ht clang)) + (define has-hole-ht (compiled-lang-has-hole-ht clang)) + (define across-ht (compiled-lang-across-ht clang)) + (define across-list-ht (compiled-lang-across-list-ht clang)) + + (define (compile-pattern/default-cache pattern) + (compile-pattern/cache pattern + (if bind-names? + (compiled-lang-bind-names-cache clang) + (compiled-lang-cache clang)))) + + (define (compile-pattern/cache pattern compiled-pattern-cache) + (let ([compiled-cache (hash-table-get compiled-pattern-cache pattern uniq)]) + (cond + [(eq? compiled-cache uniq) + (let-values ([(compiled-pattern has-hole?) + (true-compile-pattern pattern)]) + (let ([val (list (memoize compiled-pattern has-hole?) has-hole?)]) + (hash-table-put! compiled-pattern-cache pattern val) + (apply values val)))] + [else + (apply values compiled-cache)]))) + + (define (true-compile-pattern pattern) + (match pattern + [(? (lambda (x) (eq? x '....))) + (error 'compile-language "the pattern .... can only be used in extend-language")] + [`(variable-except ,@(vars ...)) + (values + (lambda (exp hole-info) + (and (symbol? exp) + (not (memq exp vars)) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)] + [`(variable-prefix ,var) + (values + (let* ([prefix-str (symbol->string var)] + [prefix-len (string-length prefix-str)]) + (lambda (exp hole-info) + (and (symbol? exp) + (let ([str (symbol->string exp)]) + (and ((string-length str) . >= . prefix-len) + (string=? (substring str 0 prefix-len) prefix-str) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none))))))) + #f)] + [`variable-not-otherwise-mentioned + (values + (let ([literals (compiled-lang-literals clang)]) + (lambda (exp hole-info) + (and (symbol? exp) + (not (memq exp literals)) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none))))) + #f)] + [`hole + (values (match-hole none) #t)] + [`(hole ,hole-id) + (values (match-hole (or hole-id none)) #t)] + [(? string?) + (values + (lambda (exp hole-info) + (and (string? exp) + (string=? exp pattern) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)] + [(? symbol?) + (cond + [(has-underscore? pattern) + (let*-values ([(binder before-underscore) + (let ([before (split-underscore pattern)]) + (unless (or (hash-table-maps? clang-ht before) + (memq before underscore-allowed)) + (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" + before + (format "~s" (list* 'one 'of: (hash-table-map clang-ht (λ (x y) x)))) + pattern)) + (values pattern before))] + [(match-raw-name has-hole?) + (compile-id-pattern before-underscore)]) + (values + (match-named-pat binder match-raw-name) + has-hole?))] + [else + (let-values ([(match-raw-name has-hole?) (compile-id-pattern pattern)]) + (values (if (non-underscore-binder? pattern) + (match-named-pat pattern match-raw-name) + match-raw-name) + has-hole?))])] + [`(cross ,(? symbol? pre-id)) + (let ([id (if prefix-cross? + (symbol-append pre-id '- pre-id) + pre-id)]) + (cond + [(hash-table-maps? across-ht id) + (values + (lambda (exp hole-info) + (match-nt (hash-table-get across-list-ht id) + (hash-table-get across-ht id) + id exp hole-info)) + #t)] + [else + (error 'compile-pattern "unknown cross reference ~a" id)]))] + + [`(name ,name ,pat) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) + (values (match-named-pat name match-pat) + has-hole?))] + [`(in-hole ,context ,contractum) + (let-values ([(match-context ctxt-has-hole?) (compile-pattern/default-cache context)] + [(match-contractum contractum-has-hole?) (compile-pattern/default-cache contractum)]) + (values + (match-in-hole context contractum exp match-context match-contractum none) + (or ctxt-has-hole? contractum-has-hole?)))] + [`(hide-hole ,p) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache p)]) + (values + (lambda (exp hole-info) + (let ([matches (match-pat exp #f)]) + (and matches + (map (λ (match) (make-mtch (mtch-bindings match) (mtch-context match) none)) + matches)))) + #f))] + [`(in-named-hole ,hole-id ,context ,contractum) + (let-values ([(match-context ctxt-has-hole?) (compile-pattern/default-cache context)] + [(match-contractum contractum-has-hole?) (compile-pattern/default-cache contractum)]) + (values + (match-in-hole context contractum exp match-context match-contractum hole-id) + (or ctxt-has-hole? contractum-has-hole?)))] + + [`(side-condition ,pat ,condition) + (let-values ([(match-pat has-hole?) (compile-pattern/default-cache pat)]) + (values + (lambda (exp hole-info) + (let ([matches (match-pat exp hole-info)]) + (and matches + (let ([filtered (filter (λ (m) (condition (mtch-bindings m))) matches)]) + (if (null? filtered) + #f + filtered))))) + has-hole?))] + [(? (lambda (x) (list? x))) ;; this eta expansion is to defeat a bug in match + (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern compile-pattern/default-cache)]) + (let ([count (and (not (ormap repeat? rewritten)) + (length rewritten))]) + (values + (lambda (exp hole-info) + (cond + [(list? exp) + ;; shortcircuit: if the list isn't the right length, give up immediately. + (if (and count + (not (= (length exp) count))) + #f + (match-list rewritten exp hole-info))] + [else #f])) + has-hole?)))] + + ;; an already comiled pattern + [(? compiled-pattern?) + ;; return #t here as a failsafe; no way to check better. + (values (compiled-pattern-cp pattern) + #t)] + + [else + (values + (lambda (exp hole-info) + (and (eqv? pattern exp) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)])) + + (define (non-underscore-binder? pattern) + (and bind-names? + (or (hash-table-maps? clang-ht pattern) + (memq pattern underscore-allowed)))) + + ;; compile-id-pattern : symbol[with-out-underscore] -> (values boolean) + (define (compile-id-pattern pat) + (match pat + [`any (simple-match 'any (λ (x) #t))] + [`number (simple-match 'number number?)] + [`string (simple-match 'string string?)] + [`variable (simple-match 'variable symbol?)] + [(? is-non-terminal?) + (values + (lambda (exp hole-info) + (match-nt (hash-table-get clang-list-ht pat) + (hash-table-get clang-ht pat) + pat exp hole-info)) + (hash-table-get has-hole-ht pat))] + [else + (values + (lambda (exp hole-info) + (and (eq? exp pat) + (list (make-mtch (make-bindings null) + (build-flat-context exp) + none)))) + #f)])) + + (define (is-non-terminal? sym) (hash-table-maps? clang-ht sym)) + + ;; simple-match : sym (any -> bool) -> (values boolean) + ;; does a match based on a built-in Scheme predicate + (define (simple-match binder pred) + (values (lambda (exp hole-info) + (and (pred exp) + (list (make-mtch + (make-bindings null) + (build-flat-context exp) + none)))) + #f)) + + (compile-pattern/default-cache pattern)) + + ;; match-named-pat : symbol -> + (define (match-named-pat name match-pat) + (let ([mismatch-bind? (regexp-match #rx"_!_" (symbol->string name))]) + (lambda (exp hole-info) + (let ([matches (match-pat exp hole-info)]) + (and matches + (map (lambda (match) + (make-mtch + (make-bindings (cons (if mismatch-bind? + (make-mismatch-bind name (mtch-context match)) + (make-bind name (mtch-context match))) + (bindings-table (mtch-bindings match)))) + (mtch-context match) + (mtch-hole match))) + matches)))))) + + ;; split-underscore : symbol -> symbol + ;; returns the text before the underscore in a symbol (as a symbol) + ;; raise an error if there is more than one underscore in the input + (define (split-underscore sym) + (let ([str (symbol->string sym)]) + (cond + [(regexp-match #rx"^([^_]*)_[^_]*$" str) + => + (λ (m) (string->symbol (cadr m)))] + [(regexp-match #rx"^([^_]*)_!_[^_]*$" str) + => + (λ (m) (string->symbol (cadr m)))] + [else + (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym)]))) + + ;; has-underscore? : symbol -> boolean + (define (has-underscore? sym) + (memq #\_ (string->list (symbol->string sym)))) + + ;; symbol->nt : symbol -> symbol + ;; strips the trailing underscore from a symbol, if one is there. + (define (symbol->nt sym) + (cond + [(has-underscore? sym) + (split-underscore sym)] + [else sym])) + + (define (memoize f needs-all-args?) + (if needs-all-args? + (memoize2 f) + (memoize1 f))) + + ; memoize1 : (x y -> w) -> x y -> w + ; memoizes a function of two arguments under the assumption + ; that the function is constant w.r.t the second + (define (memoize1 f) (memoize/key f (lambda (x y) x) nohole)) + (define (memoize2 f) (memoize/key f cons w/hole)) + + (define cache-size 350) + (define (set-cache-size! cs) (set! cache-size cs)) + + ;; original version, but without closure allocation in hash-table lookup + (define (memoize/key f key-fn statsbox) + (let ([ht (make-hash-table 'equal)] + [entries 0]) + (lambda (x y) + (if cache-size + (let* ([key (key-fn x y)]) + ;(record-cache-test! statsbox) + (unless (< entries cache-size) + (set! entries 0) + (set! ht (make-hash-table 'equal))) + (let ([ans (hash-table-get ht key uniq)]) + (cond + [(eq? ans uniq) + ;(record-cache-miss! statsbox) + (set! entries (+ entries 1)) + (let ([res (f x y)]) + (hash-table-put! ht key res) + res)] + [else + ans]))) + (f x y))))) + + ;; hash-table version, but with an extra hash-table that tells when to evict cache entries + #; + (define (memoize/key f key-fn statsbox) + (let* ([cache-size 50] + [ht (make-hash-table 'equal)] + [uniq (gensym)] + [when-to-evict-table (make-hash-table)] + [pointer 0]) + (lambda (x y) + (record-cache-test! statsbox) + (let* ([key (key-fn x y)] + [value-in-cache (hash-table-get ht key uniq)]) + (cond + [(eq? value-in-cache uniq) + (record-cache-miss! statsbox) + (let ([res (f x y)]) + (let ([to-remove (hash-table-get when-to-evict-table pointer uniq)]) + (unless (eq? uniq to-remove) + (hash-table-remove! ht to-remove))) + (hash-table-put! when-to-evict-table pointer key) + (hash-table-put! ht key res) + (set! pointer (modulo (+ pointer 1) cache-size)) + res)] + [else + value-in-cache]))))) + + ;; lru cache + ;; for some reason, this seems to hit *less* than the "just dump stuff out" strategy! + #; + (define (memoize/key f key-fn statsbox) + (let* ([cache-size 50] + [cache '()]) + (lambda (x y) + (record-cache-test! statsbox) + (let ([key (key-fn x y)]) + (cond + [(null? cache) + ;; empty cache + (let ([ans (f x y)]) + (record-cache-miss! statsbox) + (set! cache (cons (cons key ans) '())) + ans)] + [(null? (cdr cache)) + ;; one element cache + (if (equal? (car (car cache)) key) + (cdr (car cache)) + (let ([ans (f x y)]) + (record-cache-miss! statsbox) + (set! cache (cons (cons key ans) cache)) + ans))] + [else + ;; two of more element cache + (cond + [(equal? (car (car cache)) key) + ;; check first element + (cdr (car cache))] + [(equal? (car (cadr cache)) key) + ;; check second element + (cdr (cadr cache))] + [else + ;; iterate from the 3rd element onwards + (let loop ([previous2 cache] + [previous1 (cdr cache)] + [current (cddr cache)] + [i 0]) + (cond + [(null? current) + ;; found the end of the cache -- need to drop the last element if the cache is too full, + ;; and put the current value at the front of the cache. + (let ([ans (f x y)]) + (record-cache-miss! statsbox) + (set! cache (cons (cons key ans) cache)) + (unless (< i cache-size) + ;; drop the last element from the cache + (set-cdr! previous2 '())) + ans)] + [else + (let ([entry (car current)]) + (cond + [(equal? (car entry) key) + ;; found a hit + + ; remove this element from the list where it is. + (set-cdr! previous1 (cdr current)) + + ; move it to the front of the cache + (set! cache (cons current cache)) + + ; return the found element + (cdr entry)] + [else + ;; didnt hit yet, continue searchign + (loop previous1 current (cdr current) (+ i 1))]))]))])]))))) + + ;; hash-table version, but with a vector that tells when to evict cache entries + #; + (define (memoize/key f key-fn statsbox) + (let* ([cache-size 50] + [ht (make-hash-table 'equal)] + [uniq (gensym)] + [vector (make-vector cache-size uniq)] ;; vector is only used to evict things from the hash-table + [pointer 0]) + (lambda (x y) + (let* ([key (key-fn x y)] + [value-in-cache (hash-table-get ht key uniq)]) + (cond + [(eq? value-in-cache uniq) + (let ([res (f x y)]) + (let ([to-remove (vector-ref vector pointer)]) + (unless (eq? uniq to-remove) + (hash-table-remove! ht to-remove))) + (vector-set! vector pointer key) + (hash-table-put! ht key res) + (set! pointer (modulo (+ pointer 1) cache-size)) + res)] + [else + value-in-cache]))))) + + ;; vector-based version, with a cleverer replacement strategy + #; + (define (memoize/key f key-fn statsbox) + (let* ([cache-size 20] + ;; cache : (vector-of (union #f (cons key val))) + ;; the #f correspond to empty spots in the cache + [cache (make-vector cache-size #f)] + [pointer 0]) + (lambda (x y) + (let ([key (key-fn x y)]) + (let loop ([i 0]) + (cond + [(= i cache-size) + (unless (vector-ref cache pointer) + (vector-set! cache pointer (cons #f #f))) + (let ([pair (vector-ref cache pointer)] + [ans (f x y)]) + (set-car! pair key) + (set-cdr! pair ans) + (set! pointer (modulo (+ 1 pointer) cache-size)) + ans)] + [else + (let ([entry (vector-ref cache i)]) + (if entry + (let ([e-key (car entry)] + [e-val (cdr entry)]) + (if (equal? e-key key) + e-val + (loop (+ i 1)))) + + ;; if we hit a #f, just skip ahead and store this in the cache + (loop cache-size)))])))))) + + ;; original version + #; + (define (memoize/key f key-fn statsbox) + (let ([ht (make-hash-table 'equal)] + [entries 0]) + (lambda (x y) + (record-cache-test! statsbox) + (let* ([key (key-fn x y)] + [compute/cache + (lambda () + (set! entries (+ entries 1)) + (record-cache-miss! statsbox) + (let ([res (f x y)]) + (hash-table-put! ht key res) + res))]) + (unless (< entries 200) ; 10000 was original size + (set! entries 0) + (set! ht (make-hash-table 'equal))) + (hash-table-get ht key compute/cache))))) + + (define (record-cache-miss! statsbox) + (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox))) + (set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox)))) + + (define (record-cache-test! statsbox) + (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))) + + (define-struct cache-stats (name misses hits)) + (define (new-cache-stats name) (make-cache-stats name 0 0)) + + (define w/hole (new-cache-stats "hole")) + (define nohole (new-cache-stats "no-hole")) + + (define (print-stats) + (let ((stats (list w/hole nohole))) + (for-each + (lambda (s) + (when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0) + (printf "~a has ~a hits, ~a misses (~a% miss rate)\n" + (cache-stats-name s) + (cache-stats-hits s) + (cache-stats-misses s) + (floor + (* 100 (/ (cache-stats-misses s) + (+ (cache-stats-hits s) (cache-stats-misses s)))))))) + stats) + (let ((overall-hits (apply + (map cache-stats-hits stats))) + (overall-miss (apply + (map cache-stats-misses stats)))) + (printf "---\nOverall hits: ~a\n" overall-hits) + (printf "Overall misses: ~a\n" overall-miss) + (when (> (+ overall-hits overall-miss) 0) + (printf "Overall miss rate: ~a%\n" + (floor (* 100 (/ overall-miss (+ overall-hits overall-miss))))))))) + + ;; match-hole : (union none symbol) -> compiled-pattern + (define (match-hole hole-id) + (let ([mis-matched-hole + (λ (exp) + (and (hole? exp) + (equal? (hole-name exp) hole-id) + (list (make-mtch (make-bindings '()) + (make-hole/intern (hole-name exp)) + none))))]) + (lambda (exp hole-info) + (if hole-info + (if (eq? hole-id hole-info) + (list (make-mtch (make-bindings '()) + (make-hole/intern hole-info) + exp)) + (mis-matched-hole exp)) + (mis-matched-hole exp))))) + + ;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern + (define (match-in-hole context contractum exp match-context match-contractum hole-info) + (lambda (exp old-hole-info) + (let ([mtches (match-context exp hole-info)]) + (and mtches + (let loop ([mtches mtches] + [acc null]) + (cond + [(null? mtches) acc] + [else + (let* ([mtch (car mtches)] + [bindings (mtch-bindings mtch)] + [hole-exp (mtch-hole mtch)] + [contractum-mtches (match-contractum hole-exp old-hole-info)]) + (when (eq? none hole-exp) + (error 'matcher.ss "found zero holes when matching a decomposition")) + (if contractum-mtches + (let i-loop ([contractum-mtches contractum-mtches] + [acc acc]) + (cond + [(null? contractum-mtches) (loop (cdr mtches) acc)] + [else (let* ([contractum-mtch (car contractum-mtches)] + [contractum-bindings (mtch-bindings contractum-mtch)]) + (i-loop + (cdr contractum-mtches) + (cons + (make-mtch (make-bindings + (append (bindings-table contractum-bindings) + (bindings-table bindings))) + (build-nested-context + (mtch-context mtch) + (mtch-context contractum-mtch) + hole-info) + (mtch-hole contractum-mtch)) + acc)))])) + (loop (cdr mtches) acc)))])))))) + + ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings)) + (define (match-list patterns exp hole-info) + (let (;; raw-match : (listof (listof (listof mtch))) + [raw-match (match-list/raw patterns exp hole-info)]) + + (and (not (null? raw-match)) + + (let* (;; combined-matches : (listof (listof mtch)) + ;; a list of complete possibilities for matches + ;; (analagous to multiple matches of a single non-terminal) + [combined-matches (map combine-matches raw-match)] + + ;; flattened-matches : (union #f (listof bindings)) + [flattened-matches (if (null? combined-matches) + #f + (apply append combined-matches))]) + flattened-matches)))) + + ;; match-list/raw : (listof (union repeat compiled-pattern)) + ;; sexp + ;; hole-info + ;; -> (listof (listof (listof mtch))) + ;; the result is the raw accumulation of the matches for each subpattern, as follows: + ;; (listof (listof (listof mtch))) + ;; \ \ \-------------/ a match for one position in the list (failures don't show up) + ;; \ \-------------------/ one element for each position in the pattern list + ;; \-------------------------/ one element for different expansions of the ellipses + ;; the failures to match are just removed from the outer list before this function finishes + ;; via the `fail' argument to `loop'. + (define (match-list/raw patterns exp hole-info) + (let/ec k + (let loop ([patterns patterns] + [exp exp] + ;; fail : -> alpha + ;; causes one possible expansion of ellipses to fail + ;; initially there is only one possible expansion, so + ;; everything fails. + [fail (lambda () (k null))]) + (cond + [(pair? patterns) + (let ([fst-pat (car patterns)]) + (cond + [(repeat? fst-pat) + (if (or (null? exp) (pair? exp)) + (let ([r-pat (repeat-pat fst-pat)] + [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat)) + (build-flat-context '()) + none)]) + (apply + append + (cons (let/ec k + (let ([mt-fail (lambda () (k null))]) + (map (lambda (pat-ele) + (cons (add-ellipses-index (list r-mt) (repeat-suffix fst-pat) (repeat-mismatch? fst-pat) 0) + pat-ele)) + (loop (cdr patterns) exp mt-fail)))) + (let r-loop ([exp exp] + ;; past-matches is in reverse order + ;; it gets reversed before put into final list + [past-matches (list r-mt)] + [index 1]) + (cond + [(pair? exp) + (let* ([fst (car exp)] + [m (r-pat fst hole-info)]) + (if m + (let* ([combined-matches (collapse-single-multiples m past-matches)] + [reversed + (add-ellipses-index + (reverse-multiples combined-matches) + (repeat-suffix fst-pat) + (repeat-mismatch? fst-pat) + index)]) + (cons + (let/ec fail-k + (map (lambda (x) (cons reversed x)) + (loop (cdr patterns) + (cdr exp) + (lambda () (fail-k null))))) + (r-loop (cdr exp) + combined-matches + (+ index 1)))) + (list null)))] + ;; what about dotted pairs? + [else (list null)]))))) + (fail))] + [else + (cond + [(pair? exp) + (let* ([fst-exp (car exp)] + [match (fst-pat fst-exp hole-info)]) + (if match + (let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch) + (build-list-context (mtch-context mtch)) + (mtch-hole mtch))) + match)]) + (map (lambda (x) (cons exp-match x)) + (loop (cdr patterns) (cdr exp) fail))) + (fail)))] + [else + (fail)])]))] + [else + (if (null? exp) + (list null) + (fail))])))) + + ;; add-ellipses-index : (listof mtch) sym boolean number -> (listof mtch) + (define (add-ellipses-index mtchs key mismatch-bind? i) + (if key + (let ([rib (if mismatch-bind? + (make-mismatch-bind key i) + (make-bind key i))]) + (map (λ (mtch) (make-mtch (make-bindings (cons rib (bindings-table (mtch-bindings mtch)))) + (mtch-context mtch) + (mtch-hole mtch))) + mtchs)) + mtchs)) + + ;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists]) + (define (collapse-single-multiples bindingss multiple-bindingss) + (apply append + (map + (lambda (multiple-match) + (let ([multiple-bindings (mtch-bindings multiple-match)]) + (map + (lambda (single-match) + (let ([single-bindings (mtch-bindings single-match)]) + (let ([rib-ht (make-hash-table 'equal)] + [mismatch-rib-ht (make-hash-table 'equal)]) + (for-each + (lambda (multiple-rib) + (cond + [(bind? multiple-rib) + (hash-table-put! rib-ht (bind-name multiple-rib) (bind-exp multiple-rib))] + [(mismatch-bind? multiple-rib) + (hash-table-put! mismatch-rib-ht (mismatch-bind-name multiple-rib) (mismatch-bind-exp multiple-rib))])) + (bindings-table multiple-bindings)) + (for-each + (lambda (single-rib) + (cond + [(bind? single-rib) + (let* ([key (bind-name single-rib)] + [rst (hash-table-get rib-ht key '())]) + (hash-table-put! rib-ht key (cons (bind-exp single-rib) rst)))] + [(mismatch-bind? single-rib) + (let* ([key (mismatch-bind-name single-rib)] + [rst (hash-table-get mismatch-rib-ht key '())]) + (hash-table-put! mismatch-rib-ht key (cons (mismatch-bind-exp single-rib) rst)))])) + (bindings-table single-bindings)) + (make-mtch (make-bindings (append (hash-table-map rib-ht make-bind) + (hash-table-map mismatch-rib-ht make-mismatch-bind))) + (build-cons-context + (mtch-context single-match) + (mtch-context multiple-match)) + (pick-hole (mtch-hole single-match) + (mtch-hole multiple-match)))))) + bindingss))) + multiple-bindingss))) + + ;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp) + (define (pick-hole s1 s2) + (cond + [(eq? none s1) s2] + [(eq? none s2) s1] + ;; MF: error message simplified because it is too close to + ;; implementation matters. + [(error 'matcher.ss "found two holes" #;s1 #;s2)])) + + ;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists]) + ;; reverses the rhs of each rib in the bindings and reverses the context. + (define (reverse-multiples matches) + (map (lambda (match) + (let ([bindings (mtch-bindings match)]) + (make-mtch + (make-bindings + (map (lambda (rib) + (cond + [(bind? rib) + (make-bind (bind-name rib) + (reverse (bind-exp rib)))] + [(mismatch-bind? rib) + (make-mismatch-bind (mismatch-bind-name rib) + (reverse (mismatch-bind-exp rib)))])) + (bindings-table bindings))) + (reverse-context (mtch-context match)) + (mtch-hole match)))) + matches)) + + ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info + ;; -> (union #f (listof bindings)) + (define (match-nt list-rhs non-list-rhs nt term hole-info) + (let loop ([rhss (if (or (null? term) (pair? term)) + list-rhs + non-list-rhs)] + [ht #f]) + (cond + [(null? rhss) + (if ht + (hash-table-map ht (λ (k v) k)) + #f)] + [else + (let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) + (cond + [mth + (let ([ht (or ht (make-hash-table 'equal))]) + (for-each (λ (x) (hash-table-put! ht x #t)) mth) + (loop (cdr rhss) ht))] + [else + (loop (cdr rhss) ht)]))]))) + + ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch)) + (define (remove-bindings/filter matches) + (and matches + (let ([filtered (filter-multiples matches)]) + (and (not (null? filtered)) + (map (λ (match) + (make-mtch (make-bindings '()) + (mtch-context match) + (mtch-hole match))) + matches))))) + + ;; rewrite-ellipses : (symbol -> boolean) + ;; (listof pattern) + ;; (pattern -> (values compiled-pattern boolean)) + ;; -> (values (listof (union repeat compiled-pattern)) boolean) + ;; moves the ellipses out of the list and produces repeat structures + (define (rewrite-ellipses non-underscore-binder? pattern compile) + (let loop ([exp-eles pattern] + [fst dummy]) + (cond + [(null? exp-eles) + (if (eq? fst dummy) + (values empty #f) + (let-values ([(compiled has-hole?) (compile fst)]) + (values (list compiled) has-hole?)))] + [else + (let ([exp-ele (car exp-eles)]) + (cond + [(or (eq? '... exp-ele) + (prefixed-with? "..._" exp-ele)) + (when (eq? fst dummy) + (error 'match-pattern "bad ellipses placement: ~s" pattern)) + (let-values ([(compiled has-hole?) (compile fst)] + [(rest rest-has-hole?) (loop (cdr exp-eles) dummy)]) + (let ([underscore-key (if (eq? exp-ele '...) #f exp-ele)] + [mismatch? (and (regexp-match #rx"_!_" (symbol->string exp-ele)) #t)]) + (values + (cons (make-repeat compiled (extract-empty-bindings non-underscore-binder? fst) underscore-key mismatch?) + rest) + (or has-hole? rest-has-hole?))))] + [(eq? fst dummy) + (loop (cdr exp-eles) exp-ele)] + [else + (let-values ([(compiled has-hole?) (compile fst)] + [(rest rest-has-hole?) (loop (cdr exp-eles) exp-ele)]) + (values + (cons compiled rest) + (or has-hole? rest-has-hole?)))]))]))) + + (define (prefixed-with? prefix exp) + (and (symbol? exp) + (let* ([str (symbol->string exp)] + [len (string-length str)]) + (and (len . >= . (string-length prefix)) + (string=? (substring str 0 (string-length prefix)) + prefix))))) + + (define dummy (box 0)) + + ;; extract-empty-bindings : (symbol -> boolean) pattern -> (listof rib) + (define (extract-empty-bindings non-underscore-binder? pattern) + (let loop ([pattern pattern] + [ribs null]) + (match pattern + [`(variable-except ,@(vars ...)) ribs] + [`(variable-prefix ,vars) ribs] + [`variable-not-otherwise-mentioned ribs] + + [`hole (error 'match-pattern "cannot have a hole inside an ellipses")] + [(? symbol?) + (cond + [(regexp-match #rx"_!_" (symbol->string pattern)) + (cons (make-mismatch-bind pattern '()) ribs)] + [(or (has-underscore? pattern) + (non-underscore-binder? pattern)) + (cons (make-bind pattern '()) ribs)] + [else ribs])] + [`(name ,name ,pat) + (if (regexp-match #rx"_!_" (symbol->string name)) + (loop pat (cons (make-mismatch-bind name '()) ribs)) + (loop pat (cons (make-bind name '()) ribs)))] + [`(in-hole ,context ,contractum) (loop context (loop contractum ribs))] + [`(hide-hole ,p) (loop p ribs)] + [`(in-named-hole ,hole-name ,context ,contractum) (loop context (loop contractum ribs))] + [`(side-condition ,pat ,test) (loop pat ribs)] + [(? list?) + (let-values ([(rewritten has-hole?) (rewrite-ellipses non-underscore-binder? pattern (lambda (x) (values x #f)))]) + (let i-loop ([r-exps rewritten] + [ribs ribs]) + (cond + [(null? r-exps) ribs] + [else (let ([r-exp (car r-exps)]) + (cond + [(repeat? r-exp) + (i-loop + (cdr r-exps) + (append (repeat-empty-bindings r-exp) ribs))] + [else + (i-loop + (cdr r-exps) + (loop (car r-exps) ribs))]))])))] + [else ribs]))) + + ;; combine-matches : (listof (listof mtch)) -> (listof mtch) + ;; input is the list of bindings corresonding to a piecewise match + ;; of a list. produces all of the combinations of complete matches + (define (combine-matches matchess) + (let loop ([matchess matchess]) + (cond + [(null? matchess) (list (make-mtch (make-bindings null) (build-flat-context '()) none))] + [else (combine-pair (car matchess) (loop (cdr matchess)))]))) + + ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch) + (define (combine-pair fst snd) + (let ([mtchs null]) + (for-each + (lambda (mtch1) + (for-each + (lambda (mtch2) + (set! mtchs (cons (make-mtch + (make-bindings (append (bindings-table (mtch-bindings mtch1)) + (bindings-table (mtch-bindings mtch2)))) + (build-append-context (mtch-context mtch1) (mtch-context mtch2)) + (pick-hole (mtch-hole mtch1) + (mtch-hole mtch2))) + mtchs))) + snd)) + fst) + mtchs)) + + (define (hash-table-maps? ht key) + (not (eq? (hash-table-get ht key uniq) uniq))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; context adt + ;; + + #| + ;; This version of the ADT isn't right yet -- + ;; need to figure out what to do about (name ...) patterns. + + (define-values (struct:context make-context context? context-ref context-set!) + (make-struct-type 'context #f 1 0 #f '() #f 0)) + (define hole values) + (define (build-flat-context exp) (make-context (lambda (x) exp))) + (define (build-cons-context c1 c2) (make-context (lambda (x) (cons (c1 x) (c2 x))))) + (define (build-append-context l1 l2) (make-context (lambda (x) (append (l1 x) (l2 x))))) + (define (build-list-context l) (make-context (lambda (x) (list (l x))))) + (define (build-nested-context c1 c2) (make-context (lambda (x) (c1 (c2 x))))) + (define (plug exp hole-stuff) (exp hole-stuff)) + (define (reverse-context c) (make-context (lambda (x) (reverse (c x))))) + +|# + (define (context? x) #t) + (define-values (make-hole/intern hole-name hole?) + (let () + (define-struct hole () #f) + (define-struct (named-hole hole) (name) #f) + (define (hole-name h) + (cond + [(named-hole? h) + (named-hole-name h)] + [(hole? h) + none] + [else (error 'hole-name "expected a hole, given ~e" h)])) + (define (make-hole/intern a) + (or (hash-table-get hole-cache a #f) + (let ([h (make-named-hole a)]) + (hash-table-put! hole-cache a h) + h))) + (define the-hole? + (let ([hole? (λ (x) (or (hole? x) (named-hole? x)))]) + hole?)) + (define hole-cache (make-hash-table 'equal)) + (hash-table-put! hole-cache none (make-hole)) ;; see the cache to avoid a case in make-hole/intern + (values make-hole/intern hole-name the-hole?))) + + (define (build-flat-context exp) exp) + (define (build-cons-context e1 e2) (cons e1 e2)) + (define (build-append-context e1 e2) (append e1 e2)) + (define (build-list-context x) (list x)) + (define (reverse-context x) (reverse x)) + (define (build-nested-context c1 c2 hole-info) + (plug c1 c2 hole-info)) + (define plug + (case-lambda + [(exp hole-stuff) (plug exp hole-stuff none)] + [(exp hole-stuff hole-info) + (let ([done? #f]) + (let loop ([exp exp]) + (cond + [(pair? exp) + (cons (loop (car exp)) + (if done? + (cdr exp) + (loop (cdr exp))))] + + [(and (hole? exp) + (equal? (hole-name exp) hole-info)) + (set! done? #t) + hole-stuff] + [else exp])))])) + + ;; + ;; end context adt + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; used in hash-table lookups to tell when something isn't in the table + (define uniq (gensym)) + + (provide/contract + (match-pattern (compiled-pattern? any/c . -> . (union false/c (listof mtch?)))) + (compile-pattern (-> compiled-lang? any/c boolean? + compiled-pattern?)) + + (set-cache-size! (-> (or/c false/c (and/c integer? positive?)) void?)) + + (make-bindings ((listof bind?) . -> . bindings?)) + (bindings-table (bindings? . -> . (listof bind?))) + (bindings? (any/c . -> . boolean?)) + + (mtch? (any/c . -> . boolean?)) + (make-mtch (bindings? any/c any/c . -> . mtch?)) + (mtch-bindings (mtch? . -> . bindings?)) + (mtch-context (mtch? . -> . any/c)) + (mtch-hole (mtch? . -> . (union none? any/c))) + + (make-bind (symbol? any/c . -> . bind?)) + (bind? (any/c . -> . boolean?)) + (bind-name (bind? . -> . symbol?)) + (bind-exp (bind? . -> . any/c)) + (compile-language (-> any/c (listof nt?) (listof (listof symbol?)) compiled-lang?)) + (symbol->nt (symbol? . -> . symbol?)) + (split-underscore (symbol? . -> . symbol?))) + (provide compiled-pattern? + print-stats) + + ;; for test suite + (provide build-cons-context + build-flat-context + context?) + + (provide (struct nt (name rhs)) + (struct rhs (pattern var-info)) + (struct compiled-lang + (lang ht list-ht across-ht across-list-ht has-hole-ht cache pict-builder literals nt-map)) + + lookup-binding + + compiled-pattern + + plug + none? none + + make-repeat + make-hole/intern hole? hole-name + rewrite-ellipses + build-compatible-context-language)) diff --git a/collects/redex/private/pict-test.ss b/collects/redex/private/pict-test.ss new file mode 100644 index 0000000000..c757202fd3 --- /dev/null +++ b/collects/redex/private/pict-test.ss @@ -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")) \ No newline at end of file diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss new file mode 100644 index 0000000000..a64c41c045 --- /dev/null +++ b/collects/redex/private/pict.ss @@ -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)) diff --git a/collects/redex/private/red-sem-macro-helpers.ss b/collects/redex/private/red-sem-macro-helpers.ss new file mode 100644 index 0000000000..c88c684e31 --- /dev/null +++ b/collects/redex/private/red-sem-macro-helpers.ss @@ -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))))) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss new file mode 100644 index 0000000000..54690120d2 --- /dev/null +++ b/collects/redex/private/reduction-semantics.ss @@ -0,0 +1,1613 @@ +#lang scheme/base + +(require "matcher.ss" + "struct.ss" + "term.ss" + "loc-wrapper.ss" + (lib "list.ss") + (lib "etc.ss")) + +(require (for-syntax (lib "name.ss" "syntax") + "rewrite-side-conditions.ss" + "term-fn.ss" + (lib "boundmap.ss" "syntax") + scheme/base)) + +(define (language-nts lang) + (hash-map (compiled-lang-ht lang) (λ (x y) x))) + +(define-syntax (term-match/single stx) + (syntax-case stx () + [(_ lang [pattern rhs] ...) + (begin + (unless (identifier? #'lang) + (raise-syntax-error 'term-match/single "expected an identifier in the language position" stx #'lang)) + (let ([lang-nts (language-id-nts #'lang 'term-match/single)]) + (with-syntax ([(((names ...) (names/ellipses ...)) ...) + (map (λ (x) (let-values ([(names names/ellipses) (extract-names lang-nts 'term-match/single #t x)]) + (list names names/ellipses))) + (syntax->list (syntax (pattern ...))))] + [(side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs lang-nts 'term-match #t x)) + (syntax->list (syntax (pattern ...))))] + [(cp-x ...) (generate-temporaries #'(pattern ...))]) + #'(let ([lang-x lang]) + (let ([cp-x (compile-pattern lang-x `side-conditions-rewritten #t)] ...) + (λ (exp) + (let/ec k + (let ([match (match-pattern cp-x exp)]) + (when match + (unless (null? (cdr match)) + (error 'term-match "pattern ~s matched term ~e multiple ways" + 'pattern + exp)) + (k (term-let ([names/ellipses (lookup-binding (mtch-bindings (car match)) 'names)] ...) + rhs)))) + ... + (error 'term-match/single "no patterns matched ~e" exp))))))))])) + +(define-syntax (term-match stx) + (syntax-case stx () + [(_ lang [pattern rhs] ...) + (begin + (unless (identifier? #'lang) + (raise-syntax-error 'term-match "expected an identifier" stx #'lang)) + (let ([lang-nts (language-id-nts #'lang 'term-match)]) + (with-syntax ([(((names ...) (names/ellipses ...)) ...) + (map (λ (x) (let-values ([(names names/ellipses) (extract-names lang-nts 'term-match #t x)]) + (list names names/ellipses))) + (syntax->list (syntax (pattern ...))))] + [(side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs lang-nts 'term-match #t x)) + (syntax->list (syntax (pattern ...))))] + [(cp-x ...) (generate-temporaries #'(pattern ...))]) + #'(let ([lang-x lang]) + (let ([cp-x (compile-pattern lang-x `side-conditions-rewritten #t)] ...) + (λ (exp) + (append + (let ([matches (match-pattern cp-x exp)]) + (if matches + (map (λ (match) + (term-let ([names/ellipses (lookup-binding (mtch-bindings match) 'names)] ...) + rhs)) + matches) + '())) ...)))))))])) + +(define-syntax (compatible-closure stx) + (syntax-case stx () + [(_ red lang nt) + (identifier? (syntax nt)) + (with-syntax ([side-conditions-rewritten (rewrite-side-conditions/check-errs (language-id-nts #'lang 'compatible-closure) + 'compatible-closure + #t + (syntax (cross nt)))]) + (syntax (do-context-closure red lang `side-conditions-rewritten 'compatible-closure)))] + [(_ red lang nt) + (raise-syntax-error 'compatible-closure "expected a non-terminal as last argument" stx (syntax nt))])) + +(define-syntax (context-closure stx) + (syntax-case stx () + [(_ red lang pattern) + (with-syntax ([side-conditions-rewritten (rewrite-side-conditions/check-errs (language-id-nts #'lang 'context-closure) + 'context-closure + #t + (syntax pattern))]) + (syntax + (do-context-closure + red + lang + `side-conditions-rewritten + 'context-closure)))])) + +(define (do-context-closure red lang pat name) + (unless (reduction-relation? red) + (error name "expected as first argument, got ~e" red)) + (unless (compiled-lang? lang) + (error name "expected as second argument, got ~e" lang)) + (let ([cp (compile-pattern + lang + `(in-hole (name ctxt ,pat) + (name exp any)) + #f)]) + (build-reduction-relation + #f + lang + (map + (λ (make-proc) + (λ (lang) + (let ([f (make-proc lang)]) + (λ (main-exp exp extend acc) + (let loop ([ms (or (match-pattern cp exp) '())] + [acc acc]) + (cond + [(null? ms) acc] + [else + (let* ([mtch (car ms)] + [bindings (mtch-bindings mtch)]) + (loop (cdr ms) + (f main-exp + (lookup-binding bindings 'exp) + (λ (x) (extend (plug (lookup-binding bindings 'ctxt) x))) + acc)))])))))) + (reduction-relation-make-procs red)) + (reduction-relation-rule-names red) + (reduction-relation-lws red)))) + +(define-syntax (--> stx) (raise-syntax-error '--> "used outside of reduction-relation")) +(define-syntax (fresh stx) (raise-syntax-error 'fresh "used outside of reduction-relation")) +(define-syntax (with stx) (raise-syntax-error 'with "used outside of reduction-relation")) + +(define (apply-reduction-relation/tag-with-names p v) + (let loop ([procs (reduction-relation-procs p)] + [acc '()]) + (cond + [(null? procs) acc] + [else + (loop (cdr procs) + ((car procs) v v values acc))]))) + +(define (apply-reduction-relation p v) (map cadr (apply-reduction-relation/tag-with-names p v))) + +(define-for-syntax (extract-pattern-binds lhs) + (let loop ([lhs lhs]) + (syntax-case* lhs (name) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + [(name id expr) + (identifier? #'id) + (cons (cons #'id #'expr) (loop #'expr))] + ;; FIXME: should follow the grammar of patterns! + [(a . b) + (append (loop #'a) (loop #'b))] + [_else null]))) + +(define-for-syntax (extract-term-let-binds lhs) + (let loop ([lhs lhs]) + (syntax-case* lhs (term-let) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + [(term-let ((x e1) ...) e2 ...) + (append (map cons + (syntax->list #'(x ...)) + (syntax->list #'(e1 ...))) + (loop #'(e2 ...)))] + ;; FIXME: should follow the grammar of patterns! + [(a . b) + (append (loop #'a) (loop #'b))] + [_else null]))) + +(define-syntax (-reduction-relation stx) + (syntax-case stx () + [(_ lang args ...) + #'(do-reduction-relation reduction-relation empty-reduction-relation #f lang args ...)])) + +(define-syntax (extend-reduction-relation stx) + (syntax-case stx () + [(_ orig-reduction-relation lang args ...) + #'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)])) + +(define-struct successful (result)) + +(define-syntax-set (do-reduction-relation) + (define (do-reduction-relation/proc stx) + (syntax-case stx () + [(_ id orig-reduction-relation allow-zero-rules? lang args ...) + (identifier? #'lang) + (with-syntax ([(rules ...) (before-with (syntax (args ...)))] + [(shortcuts ...) (after-with (syntax (args ...)))]) + (with-syntax ([(lws ...) (map rule->lws (syntax->list #'(rules ...)))]) + (reduction-relation/helper + stx + (syntax-e #'id) + #'orig-reduction-relation + (syntax lang) + (syntax->list (syntax (rules ...))) + (syntax->list (syntax (shortcuts ...))) + #'(list lws ...) + (syntax-e #'allow-zero-rules?))))] + [(_ id orig-reduction-relation lang args ...) + (raise-syntax-error (syntax-e #'id) + "expected an identifier for the language name" + stx + #'lang)])) + + (define (before-with stx) + (let loop ([lst (syntax->list stx)]) + (cond + [(null? lst) null] + [else + (let ([fst (car lst)]) + (syntax-case (car lst) (with) + [with null] + [else (cons (car lst) (loop (cdr lst)))]))]))) + + (define (after-with stx) + (let loop ([lst (syntax->list stx)]) + (cond + [(null? lst) null] + [else + (let ([fst (car lst)]) + (syntax-case (car lst) (with) + [with (cdr lst)] + [else (loop (cdr lst))]))]))) + + (define (rule->lws rule) + (syntax-case rule () + [(arrow lhs rhs stuff ...) + (let-values ([(label scs fvars withs) + (let loop ([stuffs (syntax->list #'(stuff ...))] + [label #f] + [scs null] + [fvars null] + [withs null]) + (cond + [(null? stuffs) (values label (reverse scs) (reverse fvars) (reverse withs))] + [else + (syntax-case (car stuffs) (where fresh variable-not-in) + [(fresh xs ...) + (loop (cdr stuffs) + label + scs + (append + (reverse (map (λ (x) + (syntax-case x () + [x + (identifier? #'x) + #'x] + [(x whatever) + (identifier? #'x) + #'x] + [((y dots) (x dots2)) + (datum->syntax + #f + `(,(syntax->datum #'y) ...) + #'y)] + [((y dots) (x dots2) whatever) + (datum->syntax + #f + `(,(syntax->datum #'y) ...) + #'y)])) + (syntax->list #'(xs ...)))) + fvars) + withs)] + [(where x e) + (loop (cdr stuffs) + label + scs + fvars + (cons #'(x e) withs))] + [(side-condition sc) + (loop (cdr stuffs) + label + (cons #'sc scs) + fvars + withs)] + [x + (identifier? #'x) + (loop (cdr stuffs) + #''x + scs + fvars + withs)] + [x + (string? (syntax-e #'x)) + (loop (cdr stuffs) + #'x + scs + fvars + withs)])]))]) + (with-syntax ([(scs ...) scs] + [(fvars ...) fvars] + [((where-id where-expr) ...) withs] + [((bind-id . bind-pat) ...) + (append (extract-pattern-binds #'lhs) + (extract-term-let-binds #'rhs))]) + #`(make-rule-pict 'arrow + (to-lw lhs) + (to-lw rhs) + #,label + (list (to-lw/uq scs) ...) + (list (to-lw fvars) ...) + (list (cons (to-lw bind-id) + (to-lw bind-pat)) + ... + (cons (to-lw where-id) + (to-lw where-expr)) + ...))))])) + + (define (reduction-relation/helper stx orig-name orig-red-expr lang-id rules shortcuts lws allow-zero-rules?) + (let ([ht (make-module-identifier-mapping)] + [all-top-levels '()] + [withs (make-module-identifier-mapping)]) + (for-each (λ (shortcut) + (syntax-case shortcut () + [((rhs-arrow rhs-from rhs-to) + (lhs-arrow lhs-from lhs-to)) + (begin + (table-cons! withs #'lhs-arrow #'rhs-arrow) + (table-cons! ht (syntax rhs-arrow) shortcut))] + [((a b c) d) + (raise-syntax-error + orig-name + "malformed shortcut, expected right-hand side to have three sub-expressions" + stx (syntax d))] + [(a b) + (raise-syntax-error + orig-name + "malformed shortcut, expected left-hand side to have three sub-expressions" + stx (syntax a))] + [(a b c d ...) + (raise-syntax-error orig-name + "malformed shortcut, expected only two subparts for a shortcut definition, found an extra one" + stx + (syntax c))] + [_ (raise-syntax-error orig-name + "malformed shortcut" + stx shortcut)])) + shortcuts) + + (for-each (λ (rule) + (syntax-case rule () + [(arrow . rst) + (begin + (set! all-top-levels (cons #'arrow all-top-levels)) + (table-cons! ht (syntax arrow) rule))])) + rules) + ;; signal a syntax error if there are shortcuts defined, but no rules that use them + (unless (null? shortcuts) + (unless (module-identifier-mapping-get ht (syntax -->) (λ () #f)) + (raise-syntax-error orig-name "no --> rules" stx))) + + (for-each (λ (tl) + (let loop ([id tl]) + (unless (free-identifier=? #'--> id) + (let ([nexts + (module-identifier-mapping-get + withs id + (λ () + (raise-syntax-error + orig-name + (format "the ~s relation is not defined" + (syntax->datum id)) + stx + id)))]) + (for-each loop nexts))))) + all-top-levels) + + (let ([name-ht (make-hasheq)]) + (with-syntax ([lang-id lang-id] + [(top-level ...) (get-choices stx orig-name ht lang-id (syntax -->) name-ht lang-id allow-zero-rules?)] + [(rule-names ...) (hash-map name-ht (λ (k v) k))] + [lws lws]) + #`(build-reduction-relation + #,orig-red-expr + lang-id + (list top-level ...) + '(rule-names ...) + lws))))) + + #| + ;; relation-tree = + ;; leaf + ;; (make-node id[frm] pat[frm] id[to] pat[to] (listof relation-tree)) + (define-struct node (frm-id frm-pat to-id to-pat)) + (define-struct leaf (frm-pat to-pat)) + |# + ;; get-choices : stx[original-syntax-object] bm lang identifier ht[sym->syntax] identifier[language-name] -> (listof relation-tree) + (define (get-choices stx orig-name bm lang id name-table lang-id allow-zero-rules?) + (reverse + (apply + append + (map (λ (x) (get-tree stx orig-name bm lang x name-table lang-id allow-zero-rules?)) + (module-identifier-mapping-get + bm id + (λ () + (if allow-zero-rules? + '() + (raise-syntax-error orig-name + (format "no rules use ~a" (syntax->datum id)) + stx + id)))))))) + + (define (get-tree stx orig-name bm lang case-stx name-table lang-id allow-zero-rules?) + (syntax-case case-stx () + [(arrow from to extras ...) + (list (do-leaf stx + orig-name + lang + name-table + (syntax from) + (syntax to) + (syntax->list (syntax (extras ...))) + lang-id))] + [((rhs-arrow rhs-from rhs-to) (lhs-arrow lhs-frm-id lhs-to-id)) + (let ([lang-nts (language-id-nts lang-id orig-name)]) + (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t (syntax rhs-from))]) + (with-syntax ([(names ...) names] + [(names/ellipses ...) names/ellipses] + [side-conditions-rewritten (rewrite-side-conditions/check-errs + lang-nts + orig-name + #t + (rewrite-node-pat (syntax-e (syntax lhs-frm-id)) + (syntax->datum (syntax rhs-from))))] + [lang lang]) + (map + (λ (child-proc) + #`(do-node-match + 'lhs-frm-id + 'lhs-to-id + `side-conditions-rewritten + (λ (bindings rhs-binder) + (term-let ([lhs-to-id rhs-binder] + [names/ellipses (lookup-binding bindings 'names)] ...) + (term rhs-to))) + #,child-proc)) + (get-choices stx orig-name bm #'lang + (syntax lhs-arrow) + name-table lang-id + allow-zero-rules?)))))])) + (define (rewrite-node-pat id term) + (let loop ([term term]) + (cond + [(eq? id term) `(name ,id any)] + [(pair? term) (cons (loop (car term)) + (loop (cdr term)))] + [else term]))) + + (define (do-leaf stx orig-name lang name-table from to extras lang-id) + (let ([lang-nts (language-id-nts lang-id orig-name)]) + (let-values ([(name fresh-vars side-conditions/withs) (process-extras stx orig-name name-table extras)]) + (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)]) + (with-syntax ([side-conditions-rewritten + (rewrite-side-conditions/check-errs + lang-nts + orig-name + #t + from)] + [to to] + [name name] + [lang lang] + [(names ...) names] + [(names/ellipses ...) names/ellipses] + [(fresh-var-clauses ...) + (map (λ (fv-clause) + (syntax-case fv-clause () + [x + (identifier? #'x) + #'[x (variable-not-in main 'x)]] + [(x name) + (identifier? #'x) + #'[x (let ([the-name (term name)]) + (verify-name-ok '#,orig-name the-name) + (variable-not-in main the-name))]] + [((y) (x ...)) + #`[(y #,'...) + (variables-not-in main + (map (λ (_ignore_) 'y) + (term (x ...))))]] + [((y) (x ...) names) + #`[(y #,'...) + (let ([the-names (term names)] + [len-counter (term (x ...))]) + (verify-names-ok '#,orig-name the-names len-counter) + (variables-not-in main the-names))]])) + fresh-vars)]) + #`(do-leaf-match + name + `side-conditions-rewritten + (λ (main bindings) + ;; nested term-let's so that the bindings for the variables + ;; show up in the `fresh' side-conditions, the bindings for the variables + ;; show up in the withs, and the withs show up in the 'fresh' side-conditions + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + (term-let (fresh-var-clauses ...) + #,(bind-withs side-conditions/withs + #'(make-successful (term to)))))))))))) + + ;; the withs and side-conditions come in backwards order + (define (bind-withs stx body) + (let loop ([stx stx] + [body body]) + (syntax-case stx (side-condition where) + [() body] + [((where x e) y ...) + (loop #'(y ...) #`(term-let ([x (term e)]) #,body))] + [((side-condition s ...) y ...) + (loop #'(y ...) #`(and s ... #,body))]))) + + (define (process-extras stx orig-name name-table extras) + (let ([the-name #f] + [the-name-stx #f] + [fresh-vars '()] + [side-conditions/withs '()]) + (let loop ([extras extras]) + (cond + [(null? extras) (values the-name fresh-vars side-conditions/withs)] + [else + (syntax-case (car extras) (side-condition fresh where) + [name + (or (identifier? (car extras)) + (string? (syntax-e (car extras)))) + (begin + (let* ([raw-name (syntax-e (car extras))] + [name-sym + (if (symbol? raw-name) + raw-name + (string->symbol raw-name))]) + (when (hash-ref name-table name-sym #f) + (raise-syntax-errors orig-name + "same name on multiple rules" + stx + (list (hash-ref name-table name-sym) + (syntax name)))) + (hash-set! name-table name-sym (syntax name)) + + (when the-name + (raise-syntax-errors orig-name + "expected only a single name" + stx + (list the-name-stx (car extras)))) + (set! the-name (if (symbol? raw-name) + (symbol->string raw-name) + raw-name)) + (set! the-name-stx (car extras)) + (loop (cdr extras))))] + [(fresh var ...) + (begin + (set! fresh-vars + (append + (map (λ (x) + (syntax-case x () + [x + (identifier? #'x) + #'x] + [(x name) + (identifier? #'x) + #'(x name)] + [((ys dots2) (xs dots1)) + (and (eq? (syntax-e #'dots1) (string->symbol "...")) + (eq? (syntax-e #'dots2) (string->symbol "..."))) + #'((ys) (xs dots1))] + [((ys dots2) (xs dots1) names) + (and (eq? (syntax-e #'dots1) (string->symbol "...")) + (eq? (syntax-e #'dots2) (string->symbol "..."))) + #'((ys) (xs dots1) names)] + [x + (raise-syntax-error orig-name + "malformed fresh variable clause" + stx + #'x)])) + (syntax->list #'(var ...))) + fresh-vars)) + (loop (cdr extras)))] + [(side-condition exp ...) + (begin + (set! side-conditions/withs (cons (car extras) side-conditions/withs)) + (loop (cdr extras)))] + [(where x e) + (begin + (set! side-conditions/withs (cons (car extras) side-conditions/withs)) + (loop (cdr extras)))] + [(where . x) + (raise-syntax-error orig-name "malformed where clause" stx (car extras))] + [_ + (raise-syntax-error orig-name "unknown extra" stx (car extras))])])))) + + ;; table-cons! hash-table sym any -> void + ;; extends ht at key by `cons'ing hd onto whatever is alrady bound to key (or the empty list, if nothing is) + (define (table-cons! ht key hd) + (module-identifier-mapping-put! ht key (cons hd (module-identifier-mapping-get ht key (λ () '()))))) + + (define (raise-syntax-errors sym str stx stxs) + (raise (make-exn:fail:syntax + (string->immutable-string (format "~a: ~a~a" + sym + str + (if (error-print-source-location) + (string-append ":" (stxs->list stxs)) + ""))) + (current-continuation-marks) + stxs))) + + (define (stxs->list stxs) + (apply + string-append + (let loop ([stxs stxs]) + (cond + [(null? stxs) '()] + [else + (cons (format " ~s" (syntax->datum (car stxs))) + (loop (cdr stxs)))]))))) + +(define (verify-name-ok orig-name the-name) + (unless (symbol? the-name) + (error orig-name "expected a single name, got ~s" the-name))) + +(define (verify-names-ok orig-name the-names len-counter) + (unless (and (list? the-names) + (andmap symbol? the-names)) + (error orig-name + "expected a sequence of names, got ~s" + the-names)) + (unless (= (length len-counter) + (length the-names)) + (error orig-name + "expected the length of the sequence of names to be ~a, got ~s" + (length len-counter) + the-names))) + +(define (union-reduction-relations fst snd . rst) + (let ([name-ht (make-hasheq)] + [lst (list* fst snd rst)] + [first-lang (reduction-relation-lang fst)]) + (for-each + (λ (red) + (unless (eq? first-lang (reduction-relation-lang red)) + (error 'union-reduction-relations + "expected all of the reduction relations to use the same language")) + (for-each (λ (name) + (when (hash-ref name-ht name #f) + (error 'union-reduction-relations "multiple rules with the name ~s" name)) + (hash-set! name-ht name #t)) + (reduction-relation-rule-names red))) + lst) + (build-reduction-relation + #f + first-lang + (reverse (apply append (map reduction-relation-make-procs lst))) + (hash-map name-ht (λ (k v) k)) + (apply append (map reduction-relation-lws lst))))) + +(define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc) + ;; need call to make-rewrite-proc + ;; also need a test case here to check duplication of names. + (make-rewrite-proc + (λ (lang) + (let ([cp (compile-pattern lang pat #t)] + [child-proc (child-make-proc lang)]) + (λ (main-exp exp f other-matches) + (let ([mtchs (match-pattern cp exp)]) + (if mtchs + (let o-loop ([mtchs mtchs] + [acc other-matches]) + (cond + [(null? mtchs) acc] + [else + (let ([sub-exp (lookup-binding (mtch-bindings (car mtchs)) lhs-frm-id)]) + (o-loop (cdr mtchs) + (child-proc main-exp + sub-exp + (λ (x) (f (rhs-proc (mtch-bindings (car mtchs)) x))) + acc)))])) + other-matches))))) + (rewrite-proc-name child-make-proc))) + +(define (do-leaf-match name pat proc) + (make-rewrite-proc + (λ (lang) + (let ([cp (compile-pattern lang pat #t)]) + (λ (main-exp exp f other-matches) + (let ([mtchs (match-pattern cp exp)]) + (if mtchs + (map/mt (λ (mtch) + (let ([really-matched (proc main-exp (mtch-bindings mtch))]) + (and really-matched + (list name (f (successful-result really-matched)))))) + mtchs + other-matches) + other-matches))))) + name)) + +(define-syntax (test-match stx) + (syntax-case stx () + [(_ lang-exp pattern) + (identifier? #'lang-exp) + (with-syntax ([side-condition-rewritten (rewrite-side-conditions/check-errs + (language-id-nts #'lang-exp 'redex-match) + 'redex-match + #t + (syntax pattern))]) + (syntax + (do-test-match lang-exp `side-condition-rewritten)))] + [(_ lang-exp pattern expression) + (identifier? #'lang-exp) + (syntax + ((test-match lang-exp pattern) expression))] + [(_ a b c) + (raise-syntax-error 'redex-match "expected an identifier (bound to a language) as first argument" stx #'a)] + [(_ a b) + (raise-syntax-error 'redex-match "expected an identifier (bound to a language) as first argument" stx #'a)])) + +(define-struct match (bindings) #:inspector #f) + +(define (do-test-match lang pat) + (unless (compiled-lang? lang) + (error 'redex-match "expected first argument to be a language, got ~e" lang)) + (let ([cpat (compile-pattern lang pat #t)]) + (λ (exp) + (let ([ans (match-pattern cpat exp)]) + (and ans + (map (λ (m) (make-match (sort-bindings (bindings-table (mtch-bindings m))))) + ans)))))) + +(define (sort-bindings bnds) + (sort + bnds + (λ (x y) (string-ci<=? (symbol->string (bind-name x)) + (symbol->string (bind-name y)))))) + +(define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!) + (make-struct-type 'metafunc-proc #f 8 0 #f null (current-inspector) 0)) +(define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1)) +(define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2)) +(define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3)) +(define metafunc-proc-name (make-struct-field-accessor metafunc-proc-ref 4)) +(define metafunc-proc-cps (make-struct-field-accessor metafunc-proc-ref 5)) +(define metafunc-proc-rhss (make-struct-field-accessor metafunc-proc-ref 6)) +(define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 7)) +(define-struct metafunction (proc)) + +(define-syntax (in-domain? stx) + (syntax-case stx () + [(_ exp name) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f "expected an identifier" stx #'name)) + #'(in-domain?/proc (metafunction-form name) exp))])) + +(define (in-domain?/proc mf exp) + (let ([mp (metafunction-proc mf)]) + ((metafunc-proc-in-dom? mp) + (if (metafunc-proc-multi-arg? mp) + exp + (list exp))))) + +(define-syntax (define-metafunction stx) + (syntax-case stx () + [(_ name lang-exp [lhs roc ...] ...) + (with-syntax ([(lhs-w ...) (map (λ (x) (list x)) (syntax->list #'(lhs ...)))]) + (syntax/loc stx + (internal-define-metafunction + #f #f name lang-exp + [lhs-w roc ...] ...)))])) + + +(define-syntax (define-metafunction/extension stx) + (syntax-case stx () + [(_ name lang-exp prev [lhs roc ...] ...) + (identifier? #'name) + (with-syntax ([(lhs-w ...) (map (λ (x) (list x)) (syntax->list #'(lhs ...)))]) + (syntax/loc stx + (internal-define-metafunction + prev #f name lang-exp + [lhs-w roc ...] ...)))])) + +(define-syntax (define-multi-args-metafunction stx) + (syntax-case stx () + [(_ name lang-exp [(lhs ...) roc ...] ...) + (with-syntax ([s (list* #'internal-define-metafunction + #f #t + (cdr (syntax->list stx)))]) + (syntax/loc stx s))] + [(_ name lang-exp clauses ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error 'define-multi-args-metafunction "expected the name of a language" stx #'name)) + (for-each + (λ (clause) + (syntax-case clause () + [((a ...) b) (void)] + [(a b) + (raise-syntax-error 'define-multi-args-metafunction "expected lhs clause to be a sequence (with parens)" + stx + #'a)] + [else + (raise-syntax-error 'define-metafunction "expected a lhs and rhs clause" stx clause)])) + (syntax->list (syntax (clauses ...)))) + (raise-syntax-error 'define-multi-args-metafunction "missing error message check" stx))])) + +(define-syntax (define-multi-args-metafunction/extension stx) + (syntax-case stx () + [(_ name lang-exp prev [lhs roc ...] ...) + (identifier? #'name) + (syntax/loc stx + (internal-define-metafunction + prev #t name lang-exp + [lhs roc ...] ...))])) + +(define-syntax-set (internal-define-metafunction) + (define (internal-define-metafunction/proc stx) + (syntax-case stx () + [(_ prev-metafunction multi-args? name lang (lhs rhs stuff ...) ...) + (and (identifier? #'name) + (identifier? #'lang)) + (with-syntax ([(((tl-side-conds ...) ...) + (tl-bindings ...)) + (extract-side-conditions (syntax-e #'name) stx #'((stuff ...) ...))]) + (let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) + (with-syntax ([(side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + #t + 'define-metafunction + x)) + (syntax->list (syntax ((side-condition lhs (and tl-side-conds ...)) ...))))] + [(rhs-fns ...) + (map (λ (lhs rhs bindings) + (let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) + (with-syntax ([(names ...) names] + [(names/ellipses ...) names/ellipses] + [rhs rhs] + [((tl-var tl-exp) ...) bindings]) + (syntax + (λ (name bindings) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + (term-let ([tl-var tl-exp] ...) + (term-let-fn ((name name)) + (term rhs))))))))) + (syntax->list (syntax (lhs ...))) + (syntax->list (syntax (rhs ...))) + (syntax->list (syntax (tl-bindings ...))))] + [(name2) (generate-temporaries (syntax (name)))] + [((side-cond ...) ...) + ;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level + (map (lambda (lhs scs) + (append + (let loop ([lhs lhs]) + (syntax-case lhs (side-condition term) + [(side-condition pat (term sc)) + (cons #'sc (loop #'pat))] + [_else null])) + scs)) + (syntax->list #'(lhs ...)) + (syntax->list #'((tl-side-conds ...) ...)))] + [(((bind-id . bind-pat) ...) ...) + ;; Also for pict, extract pattern bindings + (map extract-pattern-binds (syntax->list #'(lhs ...)))] + [(lhs-app ...) (if (syntax-e #'multi-args?) + (syntax->list (syntax (lhs ...))) + ;; if single arg, drop the extra parens, since they have the wrong + ;; source locations anyways + (map (λ (x) (car (syntax-e x))) + (syntax->list (syntax (lhs ...)))))]) + #`(begin + (define name2 + (build-metafunction + lang + (list `side-conditions-rewritten ...) + (list rhs-fns ...) + #,(if (syntax-e #'prev-metafunction) + (let ([term-fn (syntax-local-value #'prev-metafunction)]) + #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) + #''()) + #,(if (syntax-e #'prev-metafunction) + (let ([term-fn (syntax-local-value #'prev-metafunction)]) + #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) + #''()) + (λ (f/dom cps rhss) + (make-metafunc-proc + (let ([name (lambda (x) (f/dom x #f))]) name) + (list (list (to-lw lhs-app) + (list (to-lw/uq side-cond) ...) + (list (cons (to-lw bind-id) + (to-lw bind-pat)) + ...) + (to-lw rhs)) + ...) + lang + multi-args? + 'name + cps + rhss + (let ([name (lambda (x) (f/dom x #t))]) name))) + 'name)) + (term-define-fn name name2 multi-args?)))))] + [(_ prev-metafunction multi-args? name lang clauses ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error 'define-metafunction "expected the name of a language" stx #'name)) + (unless (identifier? #'lang) + (raise-syntax-error 'define-metafunction "expected the name of a language" stx #'lang)) + (for-each + (λ (clause) + (syntax-case clause () + [(a b) (void)] + [else + (raise-syntax-error 'define-metafunction "expected a lhs and rhs clause" stx clause)])) + (syntax->list (syntax (clauses ...)))) + (raise-syntax-error 'define-metafunction "missing error check for bad syntax" stx))])) + + + (define (extract-side-conditions name stx stuffs) + (let loop ([stuffs (syntax->list stuffs)] + [side-conditionss '()] + [bindingss '()]) + (cond + [(null? stuffs) (list (reverse side-conditionss) + (reverse bindingss))] + [else + (let s-loop ([stuff (syntax->list (car stuffs))] + [side-conditions '()] + [bindings '()]) + (cond + [(null? stuff) (loop (cdr stuffs) + (cons (reverse side-conditions) side-conditionss) + (cons (reverse bindings) bindingss))] + [else + (syntax-case (car stuff) (side-condition) + [(side-condition tl-side-conds ...) + (s-loop (cdr stuff) + (append (syntax->list #'(tl-side-conds ...)) side-conditions) + bindings)] + [(where x e) + (s-loop (cdr stuff) + side-conditions + (cons #'(x e) bindings))] + [_ + (raise-syntax-error 'define-metafunction + "expected a side-condition or where clause" + (car stuff))])]))])))) + +(define (build-metafunction lang patterns rhss old-cps old-rhss wrap name) + (let ([compiled-patterns (append old-cps + (map (λ (pat) (compile-pattern lang pat #t)) patterns))]) + (wrap + (letrec ([metafunc/run (λ (x) (metafunc x #f))] + [metafunc + (λ (exp dom-test?) + (let loop ([patterns compiled-patterns] + [rhss (append old-rhss rhss)] + [num (- (length old-cps))]) + (cond + [(null? patterns) + (if dom-test? + #f + (error name "no clauses matched for ~s" `(,name . ,exp)))] + [else + (let ([pattern (car patterns)] + [rhs (car rhss)]) + (let ([mtchs (match-pattern pattern exp)]) + (cond + [(not mtchs) (loop (cdr patterns) + (cdr rhss) + (+ num 1))] + [(not (null? (cdr mtchs))) + (error name "~a matched ~s ~a different ways" + (if (< num 0) + "a clause from an extended metafunction" + (format "clause ~a" num)) + exp + (length mtchs))] + [else + (if dom-test? + #t + (rhs metafunc/run (mtch-bindings (car mtchs))))])))])))]) + metafunc) + compiled-patterns + rhss))) + +(define-syntax (metafunction-form stx) + (syntax-case stx () + [(_ id) + (identifier? #'id) + (let ([v (syntax-local-value #'id (lambda () #f))]) + (if (term-fn? v) + #`(make-metafunction #,(term-fn-get-id v)) + (raise-syntax-error + #f + "not bound as a metafunction" + stx + #'id)))])) + +;; pull-out-names : symbol syntax -> list-of-syntax[identifier identifier-or-false] +(define-for-syntax (pull-out-names form stx ids) + (let loop ([names (syntax->list ids)] + [acc '()]) + (cond + [(null? names) acc] + [else + (let* ([name (car names)] + [lst (syntax->list name)]) + (cond + [(identifier? name) (loop (cdr names) (cons #`(#,(syntax-e name) #f) acc))] + [(and (list? lst) + (andmap identifier? lst)) + (loop (cdr names) (append + (list #`(#,(car lst) #f)) + (map (λ (x) #`(#,(syntax-e x) #,(car lst))) + (cdr lst)) + acc))] + [(list? lst) + (for-each (λ (x) (unless (identifier? x) + (raise-syntax-error form "expected an identifier" stx x))) + lst)] + [else + (raise-syntax-error form + "expected an identifier or a sequence of identifiers" + stx + name)]))]))) + +(define-syntax (define-language stx) + (syntax-case stx () + [(_ name (names rhs ...) ...) + (identifier? (syntax name)) + (with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))]) + (with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))]) + (syntax/loc stx + (begin + (define-syntax name + (make-set!-transformer + (make-language-id + (case-lambda + [(stx) + (syntax-case stx (set!) + [(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)] + [(x e (... ...)) #'(define-language-name e (... ...))] + [x + (identifier? #'x) + #'define-language-name])]) + '(nt-names ...)))) + (define define-language-name (language name (names rhs ...) ...))))))])) + +(define-struct binds (source binds)) + +(define-syntax (language stx) + (syntax-case stx () + [(_ lang-id (name rhs ...) ...) + (let () + + ;; collect-binds-clauses : syntax syntax (cons syntax (listof syntax)) -> (values syntax (listof syntax)) + ;; extracts the #:binds part of a production and returns them (if any) as well as returning the + ;; list of syntax objects that follow the binds clause. + ;; production is the original production that this #:binds clause is modifying, + ;; and lang is the name of the language + (define (collect-binds-clauses production lang rhss) + (let loop ([binds '()] + [rhss rhss]) + (cond + [(or (null? (cdr rhss)) + (not (equal? (syntax-e (cadr rhss)) '#:binds))) + (values #`(list #,@(reverse binds)) (cdr rhss))] + [else + (unless (>= (length rhss) 3) + (raise-syntax-error #f + "found a #:binds clause without two following expressions" + stx + (cadr rhss))) + (let ([binds-keyword (list-ref rhss 1)] + [var (list-ref rhss 2)] + [nt (list-ref rhss 3)]) + (unless (identifier? var) + (raise-syntax-error #f + "the first argument to #:binds must be a non-terminal occurring in this right-hand side" + stx + var)) + (unless (identifier? nt) + (raise-syntax-error #f + "the second argument to #:binds must be a non-terminal occurring in this right-hand side" + stx + nt)) + (loop (cons #`(make-binds + ;; thunking like this means that the pattern is compiled each time the fn + ;; runs, ie inefficient + '#,var + '#,nt) + binds) + (cdddr rhss)))]))) + + ;; verify `name' part has the right shape + (for-each + (λ (name) + (cond + [(identifier? name) (void)] + [else + (let ([lst (syntax->list name)]) + (cond + [(list? lst) + (when (null? lst) + (raise-syntax-error 'language + "expected a sequence of identifiers with at least one identifier" + stx + name)) + (for-each (λ (x) (unless (identifier? x) + (raise-syntax-error 'language + "expected an identifier" + stx + x))) + lst)] + [else + (raise-syntax-error 'language + "expected a sequence of identifiers" + stx + lst)]))])) + (syntax->list #'(name ...))) + (let ([all-names (apply append (map (λ (x) (if (identifier? x) (list x) (syntax->list x))) + (syntax->list #'(name ...))))]) + ;; verify the names are valid names + (for-each + (λ (name) + (let ([x (syntax->datum name)]) + (when (memq x '(any number string variable variable-except variable-prefix hole name in-hole in-named-hole hide-hole side-condition cross ...)) + (raise-syntax-error 'language + (format "cannot use pattern language keyword ~a as non-terminal" + x) + stx + name)) + (when (regexp-match #rx"_" (symbol->string x)) + (raise-syntax-error 'language + "non-terminals cannot have _ in their names" + stx + name)))) + all-names) + + (with-syntax ([(((r-rhs var-info) ...) ...) + (map (lambda (rhss) + (let loop ([rhss (syntax->list rhss)]) + (cond + [(null? rhss) '()] + [else + (let ([x (car rhss)]) + (let-values ([(var-info rest) (collect-binds-clauses x #'lang rhss)]) + (cons (list (rewrite-side-conditions/check-errs + (map syntax-e all-names) + 'language + #f + x) + var-info) + (loop rest))))]))) + (syntax->list (syntax ((rhs ...) ...))))] + [(refs ...) + (let loop ([stx (syntax ((rhs ...) ...))]) + (cond + [(identifier? stx) + (if (ormap (λ (x) (bound-identifier=? x stx)) + all-names) + (list stx) + '())] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (append (loop (car stx)) + (loop (cdr stx)))] + [else '()]))]) + (with-syntax ([(the-stx ...) (cdr (syntax-e stx))] + [(all-names ...) all-names] + [((uniform-names ...) ...) + (map (λ (x) (if (identifier? x) (list x) x)) + (syntax->list (syntax (name ...))))] + [(first-names ...) + (map (λ (x) (if (identifier? x) x (car (syntax->list x)))) + (syntax->list (syntax (name ...))))] + [((new-name orig-name) ...) + (apply + append + (map (λ (name-stx) + (if (identifier? name-stx) + '() + (let ([l (syntax->list name-stx)]) + (map (λ (x) (list x (car l))) + (cdr l))))) + (syntax->list #'(name ...))))]) + + ;; note: when there are multiple names for a single non-terminal, + ;; we build equivalent non-terminals by redirecting all except the + ;; first non-terminal to the first one, and then make the first one + ;; actually have all of the productions. This should produce better + ;; caching behavior and should compile faster than duplicating the + ;; right-hand sides. + (syntax/loc stx + (begin + (let ([all-names 1] ...) + (begin (void) refs ...)) + (compile-language (list (list '(uniform-names ...) (to-lw rhs) ...) ...) + (list (make-nt 'first-names (list (make-rhs `r-rhs var-info) ...)) ... + (make-nt 'new-name (list (make-rhs 'orig-name '()))) ...) + '((uniform-names ...) ...))))))))] + [(_ (name rhs ...) ...) + (for-each + (lambda (name) + (unless (identifier? name) + (raise-syntax-error 'language "expected name" stx name))) + (syntax->list (syntax (name ...))))] + [(_ x ...) + (for-each + (lambda (x) + (syntax-case x () + [(name rhs ...) + (void)] + [_ + (raise-syntax-error 'language "malformed non-terminal" stx x)])) + (syntax->list (syntax (x ...))))])) + +(define-syntax (define-extended-language stx) + (syntax-case stx () + [(_ name orig-lang (names rhs ...) ...) + (begin + (unless (identifier? (syntax name)) + (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name)) + (unless (identifier? (syntax orig-lang)) + (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'orig-lang)) + (let ([old-names (language-id-nts #'orig-lang 'define-extended-language)]) + (with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...)) + (map (λ (x) #`(#,x #f)) old-names))]) + #'(begin + (define define-language-name (extend-language orig-lang (names rhs ...) ...)) + (define-syntax name + (make-set!-transformer + (make-language-id + (λ (stx) + (syntax-case stx (set!) + [(set! x e) (raise-syntax-error 'define-extended-language "cannot set! identifier" stx #'e)] + [(x e (... ...)) #'(define-language-name e (... ...))] + [x + (identifier? #'x) + #'define-language-name])) + '(new-nt-names ...))))))))])) + +(define-syntax (extend-language stx) + (syntax-case stx () + [(_ lang (name rhs ...) ...) + (and (identifier? #'lang) + (andmap (λ (names) + (syntax-case names () + [(name1 name2 ...) + (and (identifier? #'name1) + (andmap identifier? (syntax->list #'(name2 ...)))) + #t] + [name + (identifier? #'name) + #t] + [_ #f])) + (syntax->list (syntax/loc stx (name ...))))) + (with-syntax ([((r-rhs ...) ...) (map (lambda (rhss) (map (λ (x) (rewrite-side-conditions/check-errs + (language-id-nts #'lang 'extend-language) + 'extend-language + #f + x)) + (syntax->list rhss))) + (syntax->list (syntax ((rhs ...) ...))))] + [(first-names ...) + (map (λ (x) (if (identifier? x) x (car (syntax->list x)))) + (syntax->list (syntax (name ...))))] + [((uniform-names ...) ...) + (map (λ (x) (if (identifier? x) (list x) x)) + (syntax->list (syntax (name ...))))] + + [((new-name orig-name) ...) + (apply + append + (map (λ (name-stx) + (if (identifier? name-stx) + '() + (let ([l (syntax->list name-stx)]) + (map (λ (x) (list x (car l))) + (cdr l))))) + (syntax->list #'(name ...))))]) + (syntax/loc stx + (do-extend-language lang + (list (make-nt 'first-names (list (make-rhs `r-rhs '()) ...)) ... + (make-nt 'new-name (list (make-rhs 'orig-name '()))) ...) + (list (list '(uniform-names ...) (to-lw rhs) ...) ...))))] + [(_ lang (name rhs ...) ...) + (begin + (unless (identifier? #'lang) + (error 'extend-language "expected the name of a language" stx #'lang)) + (for-each + (lambda (name) + (unless (syntax-case name () + [(name1 name2 ...) + (and (identifier? #'name1) + (andmap identifier? #'(name2 ...))) + #t] + [name + (identifier? #'name) + #t] + [else #f]) + (raise-syntax-error 'extend-language "expected a name or a non-empty sequence of names" stx name))) + (syntax->list (syntax (name ...)))))] + [(_ lang x ...) + (for-each + (lambda (x) + (syntax-case x () + [(name rhs ...) + (void)] + [_ + (raise-syntax-error 'extend-language "malformed non-terminal" stx x)])) + (syntax->list (syntax (x ...))))])) + +(define extend-nt-ellipses '(....)) + +;; do-extend-language : compiled-lang (listof (listof nt)) ? -> compiled-lang +(define (do-extend-language old-lang new-nts new-pict-infos) + (unless (compiled-lang? old-lang) + (error 'extend-language "expected a language as first argument, got ~e" old-lang)) + (let ([old-nts (compiled-lang-lang old-lang)] + [old-ht (make-hasheq)] + [new-ht (make-hasheq)]) + (for-each (λ (nt) + (hash-set! old-ht (nt-name nt) nt) + (hash-set! new-ht (nt-name nt) nt)) + old-nts) + + (let ([extended-nts '()]) + (for-each (λ (raw-nt) + (let ([primary-name (find-primary-nt (nt-name raw-nt) old-lang)]) + (when (and primary-name (member primary-name extended-nts)) + (error 'extend-language "the non-terminal ~s was extended twice" primary-name)) + (let ([nt (make-nt (or primary-name (nt-name raw-nt)) + (nt-rhs raw-nt))]) + (cond + [(ormap (λ (rhs) (member (rhs-pattern rhs) extend-nt-ellipses)) + (nt-rhs nt)) + (unless (hash-ref old-ht (nt-name nt) #f) + (error 'extend-language + "the language extends the ~s non-terminal, but that non-terminal is not in the old language" + (nt-name raw-nt))) + (hash-set! new-ht + (nt-name nt) + (make-nt + (nt-name nt) + (append (nt-rhs (hash-ref old-ht (nt-name nt))) + (filter (λ (rhs) (not (member (rhs-pattern rhs) extend-nt-ellipses))) + (nt-rhs nt)))))] + [else + (hash-set! new-ht (nt-name nt) nt)])))) + new-nts)) + + (compile-language (vector (compiled-lang-pict-builder old-lang) + new-pict-infos) + (hash-map new-ht (λ (x y) y)) + (compiled-lang-nt-map old-lang)))) + +;; find-primary-nt : symbol lang -> symbol or #f +;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language. +(define (find-primary-nt nt lang) + (ormap (λ (nt-line) + (and (member nt nt-line) + (car nt-line))) + (compiled-lang-nt-map lang))) + +(define (apply-reduction-relation* reductions exp) + (let ([answers (make-hash)]) + (let loop ([exp exp]) + (let ([nexts (apply-reduction-relation reductions exp)]) + (cond + [(null? nexts) (hash-set! answers exp #t)] + [else (for-each loop nexts)]))) + (hash-map answers (λ (x y) x)))) + + +;; map/mt : (a -> b) (listof a) (listof b) -> (listof b) +;; map/mt is like map, except +;; a) it uses the last argument instead of the empty list +;; b) if `f' returns #f, that is not included in the result +(define (map/mt f l mt-l) + (let loop ([l l]) + (cond + [(null? l) mt-l] + [else + (let ([this-one (f (car l))]) + (if this-one + (cons this-one (loop (cdr l))) + (loop (cdr l))))]))) + +(define re:gen-d #rx".*[^0-9]([0-9]+)$") +(define (variable-not-in sexp var) + (let* ([var-str (symbol->string var)] + [var-prefix (let ([m (regexp-match #rx"^(.*[^0-9])[0-9]+$" var-str)]) + (if m + (cadr m) + var-str))] + [found-exact-var? #f] + [nums (let loop ([sexp sexp] + [nums null]) + (cond + [(pair? sexp) (loop (cdr sexp) (loop (car sexp) nums))] + [(symbol? sexp) + (when (eq? sexp var) + (set! found-exact-var? #t)) + (let* ([str (symbol->string sexp)] + [match (regexp-match re:gen-d str)]) + (if (and match + (is-prefix? var-prefix str)) + (cons (string->number (cadr match)) nums) + nums))] + [else nums]))]) + (cond + [(not found-exact-var?) var] + [(null? nums) (string->symbol (format "~a1" var))] + [else (string->symbol (format "~a~a" var-prefix (find-best-number nums)))]))) + +(define (find-best-number nums) + (let loop ([sorted (sort nums <)] + [i 1]) + (cond + [(empty? sorted) i] + [else + (let ([fst (car sorted)]) + (cond + [(< i fst) i] + [(> i fst) (loop (cdr sorted) i)] + [(= i fst) (loop (cdr sorted) (+ i 1))]))]))) + +(define (variables-not-in sexp vars) + (let loop ([vars vars] + [sexp sexp]) + (cond + [(null? vars) null] + [else + (let ([new-var (variable-not-in sexp (car vars))]) + (cons new-var + (loop (cdr vars) + (cons new-var sexp))))]))) + +(define (is-prefix? str1 str2) + (and (<= (string-length str1) (string-length str2)) + (equal? str1 (substring str2 0 (string-length str1))))) + + +;; The struct selector extracts the reduction relation rules, which +;; are in reverse order compared to the way the reduction relation was written +;; in the program text. So reverse them. +(define (reduction-relation->rule-names x) + (reverse (reduction-relation-rule-names x))) + + +; +; +; +; ; ; ;; ; +; ;; ;; ;; ;; +; ;;;;; ;;; ;;;;; ;;;;; ;;;;; ;;;; ;;;; ;;;;; ;;; ;;;;; +; ;;;;;; ;;;;; ;;;;;; ;;;;;; ;;;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;;; ;;;;;; +; ;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; +; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; +; ;;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;; ;;;;; ;;;;; ;;;; +; ;;;;; ;;;;;; ;;;;;; ;;;;; ;;;;;; ;;;;;;;;; ;;;; ;;;;; ;;;;;; ;;;;;; +; ;;;; ;;;; ;;;;; ;;;; ;;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;;; +; +; +; + +(define tests 0) +(define test-failures 0) +(define (inc-failures) (set! test-failures (+ test-failures 1))) +(define (inc-tests) (set! tests (+ tests 1))) + +(define (test-results) + (cond + [(= tests 0) + (printf "No tests run.\n")] + [(= test-failures 0) + (if (= tests 1) + (printf "One test passed.\n") + (printf "All ~a tests passed.\n" tests))] + [else + (printf "~a test~a failed (out of ~a total).\n" + test-failures + (if (= test-failures 1) "" "s") + tests)]) + (set! tests 0) + (set! test-failures 0)) + +(define-for-syntax (get-srcloc stx) + #`(list + '#,(syntax-source stx) + '#,(syntax-line stx) + '#,(syntax-column stx) + '#,(syntax-position stx))) + +(define-syntax (test--> stx) + (syntax-case stx () + [(_ red e1 e2 ...) + #`(test-->/procs red e1 (list e2 ...) #,(get-srcloc stx))])) + +(define (test-->/procs red arg expected srcinfo) + (let ([got (apply-reduction-relation* red arg)]) + (inc-tests) + (unless (set-equal? expected got) + (inc-failures) + (print-failed srcinfo) + (for-each + (λ (v2) (fprintf (current-error-port) "expected: ~v\n" v2)) + expected) + (for-each + (λ (v1) (fprintf (current-error-port) " actual: ~v\n" v1)) + got)))) + +(define (set-equal? s1 s2) + (define (⊆ s1 s2) (andmap (λ (x1) (member x1 s2)) s1)) + (and (⊆ s1 s2) + (⊆ s2 s1))) + +(define-syntax (test-predicate stx) + (syntax-case stx () + [(_ p arg) + #`(test-predicate/proc p arg #,(get-srcloc stx))])) + +(define (test-predicate/proc pred arg srcinfo) + (inc-tests) + (unless (pred arg) + (inc-failures) + (print-failed srcinfo) + (fprintf (current-error-port) " ~v\ndid not elicit ~v from ~v\n" + arg #t pred))) + +(define-syntax (test-equal stx) + (syntax-case stx () + [(_ e1 e2) + #`(test-equal/proc e1 e2 #,(get-srcloc stx))])) + +(define (test-equal/proc v1 v2 srcinfo) + (inc-tests) + (unless (equal? v1 v2) + (inc-failures) + (print-failed srcinfo) + (fprintf (current-error-port) " actual: ~v\n" v1) + (fprintf (current-error-port) "expected: ~v\n" v2))) + +(define (print-failed srcinfo) + (let ([file (list-ref srcinfo 0)] + [line (list-ref srcinfo 1)] + [column (list-ref srcinfo 2)] + [pos (list-ref srcinfo 3)]) + (fprintf (current-error-port) + "FAILED ~a~a\n" + (cond + [(path? file) + (let-values ([(base name dir) (split-path file)]) + (path->string name))] + [else ""]) + (cond + [(and line column) + (format ":~a.~a" line column)] + [pos + (format "::~a" pos)] + [else #f])))) + +(provide (rename-out [-reduction-relation reduction-relation]) + --> fresh with ;; keywords for reduction-relation + reduction-relation->rule-names + extend-reduction-relation + reduction-relation? + union-reduction-relations + + compatible-closure + context-closure + + define-language + define-extended-language + define-metafunction + define-metafunction/extension + define-multi-args-metafunction + define-multi-args-metafunction/extension + + (rename-out [metafunction-form metafunction]) + metafunction? metafunction-proc + in-domain? + metafunc-proc-lang + metafunc-proc-pict-info + metafunc-proc-name + metafunc-proc-multi-arg? + metafunc-proc-cps + metafunc-proc-rhss + metafunc-proc-in-dom? + + (struct-out binds)) + +(provide test-match + term-match + term-match/single + make-bindings bindings-table bindings? + match? match-bindings + make-bind bind? bind-name bind-exp + + test-equal + test--> + test-predicate + test-results) + + +(provide language-nts + apply-reduction-relation + apply-reduction-relation/tag-with-names + apply-reduction-relation* + variable-not-in + variables-not-in) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss new file mode 100644 index 0000000000..8086c8725b --- /dev/null +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -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))))])))) \ No newline at end of file diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss new file mode 100644 index 0000000000..058aeaf397 --- /dev/null +++ b/collects/redex/private/rg-test.ss @@ -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) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss new file mode 100644 index 0000000000..a9321d3fec --- /dev/null +++ b/collects/redex/private/rg.ss @@ -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?)]) + diff --git a/collects/redex/private/run-tests.ss b/collects/redex/private/run-tests.ss new file mode 100644 index 0000000000..84190b638d --- /dev/null +++ b/collects/redex/private/run-tests.ss @@ -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")) + diff --git a/collects/redex/private/schemeunit-test.ss b/collects/redex/private/schemeunit-test.ss new file mode 100644 index 0000000000..b8769c8333 --- /dev/null +++ b/collects/redex/private/schemeunit-test.ss @@ -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)) diff --git a/collects/redex/private/sexp-diffs.ss b/collects/redex/private/sexp-diffs.ss new file mode 100644 index 0000000000..caf1f5aad0 --- /dev/null +++ b/collects/redex/private/sexp-diffs.ss @@ -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))])))) diff --git a/collects/redex/private/size-snip.ss b/collects/redex/private/size-snip.ss new file mode 100644 index 0000000000..3d2ef658f7 --- /dev/null +++ b/collects/redex/private/size-snip.ss @@ -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)))) \ No newline at end of file diff --git a/collects/redex/private/stepper.ss b/collects/redex/private/stepper.ss new file mode 100644 index 0000000000..9eb80fc944 --- /dev/null +++ b/collects/redex/private/stepper.ss @@ -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))) diff --git a/collects/redex/private/struct.ss b/collects/redex/private/struct.ss new file mode 100644 index 0000000000..5eef043219 --- /dev/null +++ b/collects/redex/private/struct.ss @@ -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))])) diff --git a/collects/redex/private/subst-test.ss b/collects/redex/private/subst-test.ss new file mode 100644 index 0000000000..ff80736b3f --- /dev/null +++ b/collects/redex/private/subst-test.ss @@ -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))))) diff --git a/collects/redex/private/term-fn.ss b/collects/redex/private/term-fn.ss new file mode 100644 index 0000000000..618a266e39 --- /dev/null +++ b/collects/redex/private/term-fn.ss @@ -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))) diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss new file mode 100644 index 0000000000..d901df4335 --- /dev/null +++ b/collects/redex/private/term-test.ss @@ -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)) \ No newline at end of file diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss new file mode 100644 index 0000000000..9f98a3c759 --- /dev/null +++ b/collects/redex/private/term.ss @@ -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)]))) \ No newline at end of file diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss new file mode 100644 index 0000000000..86fea2f837 --- /dev/null +++ b/collects/redex/private/test-util.ss @@ -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))) + "")]) + (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)))) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss new file mode 100644 index 0000000000..33809b85ef --- /dev/null +++ b/collects/redex/private/tl-test.ss @@ -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)) diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss new file mode 100644 index 0000000000..7a57e23ddc --- /dev/null +++ b/collects/redex/private/traces.ss @@ -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) diff --git a/collects/redex/private/underscore-allowed.ss b/collects/redex/private/underscore-allowed.ss new file mode 100644 index 0000000000..b5180ce00c --- /dev/null +++ b/collects/redex/private/underscore-allowed.ss @@ -0,0 +1,3 @@ +(module underscore-allowed mzscheme + (provide underscore-allowed) + (define underscore-allowed '(any number string variable))) \ No newline at end of file diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss new file mode 100644 index 0000000000..4f2c9b4ecb --- /dev/null +++ b/collects/redex/reduction-semantics.ss @@ -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?))]) diff --git a/collects/redex/schemeunit.ss b/collects/redex/schemeunit.ss new file mode 100644 index 0000000000..402b095f43 --- /dev/null +++ b/collects/redex/schemeunit.ss @@ -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))) \ No newline at end of file diff --git a/collects/redex/subst.ss b/collects/redex/subst.ss new file mode 100644 index 0000000000..080224c857 --- /dev/null +++ b/collects/redex/subst.ss @@ -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) + "@")))) \ No newline at end of file