adjust beaucoup places in redex where the source was being

included in the compiled files. (also, misc minor cleanups
notably a new exercise in tut.scrbl)

closes PR 12547 --- there are still a few uses left, but they do not
seem to be coming from Redex proper:

 - /Users/robby/git/plt/collects/racket/private/map.rkt still appears
   in a bunch of places (there is a separate PR for that I believe),
   and

 - /Users/robby/git/plt/collects/redex/../private/reduction-semantics.rkt
   appears in tl-test.rkt, but I do not see how it
   is coming in via Redex code, so hopefully one of the other
   PRs that Eli submitted is the real cause. If not, I'll revisit later

collects/redex/examples/arithmetic.rkt

@@ -31,9 +31,9 @@
    (c--> (/ number_1 number_2)
          ,(/ (term number_1) (term number_2))
          "divide")
-   (c-->(sqrt number_1)
+   (c--> (sqrt number_1)
-        ,(sqrt (term number_1))
+         ,(sqrt (term number_1))
-        "sqrt")
+         "sqrt")
    with
    [(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
     (c--> a b)]))

collects/redex/examples/r6rs/test.rkt

@@ -2,7 +2,8 @@
 
 (require redex/reduction-semantics
          racket/contract
-         (for-syntax racket/base))
+         (for-syntax racket/base
+                     setup/path-to-relative))
 
 (define-struct test-suite (name reductions to-mz equal? tests))
 (define-struct test (name input expecteds run-mz? around file line))
@@ -71,22 +72,26 @@
   (syntax-case stx ()
     [(_ name term expected) 
      (with-syntax ([line (syntax-line stx)]
-                   [source (syntax-source stx)])
+                   [source (and (path? (syntax-source stx))
+                                (path->relative-string/library (syntax-source stx)))])
        (syntax (build-test name term (list expected) #t #f line source)))]
     [(_ name term expected mz?) 
      (with-syntax ([line (syntax-line stx)]
-                   [source (syntax-source stx)])
+                   [source (and (path? (syntax-source stx))
+                                (path->relative-string/library (syntax-source stx)))])
        (syntax (build-test name term (list expected) mz? #f line source)))]
     [(_ name term expected mz? around)
      (with-syntax ([line (syntax-line stx)]
-                   [source (syntax-source stx)])
+                   [source (and (path? (syntax-source stx))
+                                (path->relative-string/library (syntax-source stx)))])
        (syntax (build-test name term (list expected) mz? around line source)))]))
 
 (define-syntax (test/anss stx)
   (syntax-case stx ()
     [(_ name term expecteds) 
      (with-syntax ([line (syntax-line stx)]
-                   [source (syntax-source stx)])
+                   [source (and (path? (syntax-source stx))
+                                (path->relative-string/library (syntax-source stx)))])
        (syntax (build-test name term expecteds #t #f line source)))]))
 
 (define (build-test name term expecteds mz? around line source)

collects/redex/private/keyword-macros.rkt

@@ -2,6 +2,7 @@
 
 (require racket/match
          racket/contract
+         setup/path-to-relative
          (for-template racket/base racket/contract))
 
 (define (parse-kw-args formals actuals source form-name)
@@ -36,16 +37,20 @@
              (syntax rest))]
       [else (raise-syntax-error #f "bad keyword argument syntax" source rest)])))
 
+;; note: depents on current-directory (or current-load-relative-directory)
 (define (client-name stx form)
-  (let ([m (syntax-source-module stx)])
+  (define mpi/path/sym (syntax-source-module stx))
-    (cond [(module-path-index? m)
+  (define pth/sym (if (module-path-index? mpi/path/sym)
-           (format "~a" (module-path-index-resolve m))]
+                      (resolved-module-path-name 
-          [(or (symbol? m) (path? m))
+                       (module-path-index-resolve mpi/path/sym))
-           (format "~a" m)]
+                      mpi/path/sym))
-          [else (format "~s client" form)])))
+  (if (path? pth/sym)
+      (path->relative-string/library pth/sym)
+      (format "~s" pth/sym)))
 
 (define (src-loc-stx stx)
-  #`#(#,(syntax-source stx)
+  #`#(#,(and (path? (syntax-source stx))
+             (path->relative-string/library (syntax-source stx)))
       #,(syntax-line stx) 
       #,(syntax-column stx) 
       #,(syntax-position stx)
@@ -56,4 +61,7 @@
               #,(client-name expr form) '#,form
               #,desc #,(src-loc-stx expr)))
 
-(provide (all-defined-out))
+(provide src-loc-stx
+         apply-contract
+         client-name
+         parse-kw-args)

collects/redex/private/matcher.rkt

@@ -4,9 +4,6 @@
 ;;
 ;; -- jay's idea
 ;;
-;; -- when a pattern has no bindings, just use 'and's
-;;    and 'or's to check for the match (no allocation)
-;;
 ;; -- when a list pattern has only a single repeat,
 ;;    don't search for matches, just count
 ;;
@@ -25,15 +22,15 @@
 ;;    we don't return all of the bogus matches that show up
 ;;    by treating the hole as 'any'. 
 ;;
+;;    (this one turns out not to be so great because it
+;;     makes caching less effective)
+;;
 ;; -- combine the left-hand sides of a reduction relation
 ;;    so to avoid re-doing decompositions over and over
 ;;    (maybe....)
 ;;
-;; -- parallelism? but what about the hash-table?
+;; -- parallelism? but what about the hash-table cache?
 ;; 
-;; -- double check the caching code to make sure it makes 
-;;    sense in the current uni-hole world
-
 #|
 
 Note: the patterns described in the documentation are

collects/redex/private/reduction-semantics.rkt

@@ -6,7 +6,8 @@
          "fresh.rkt"
          "loc-wrapper.rkt"
          "error.rkt"
-         (for-syntax "cycle-check.rkt")
+         (for-syntax "cycle-check.rkt"
+                     setup/path-to-relative)
          racket/trace
          racket/contract
          racket/list
@@ -973,7 +974,8 @@
           (with-syntax ([(lhs-w/extras (w/extras-names ...) (w/extras-names/ellipses ...))
                          (rw-sc #`(side-condition #,from #,test-case-body-code))]
                         [lhs-source (format "~a:~a:~a"
-                                            (syntax-source from)
+                                            (and (path? (syntax-source from))
+                                                 (path->relative-string/library (syntax-source from)))
                                             (syntax-line from)
                                             (syntax-column from))]
                         [name name]
@@ -1537,7 +1539,8 @@
                              [(clause-src ...)
                               (map (λ (lhs)
                                      (format "~a:~a:~a"
-                                             (syntax-source lhs)
+                                             (and (path? (syntax-source lhs))
+                                                  (path->relative-string/library (syntax-source lhs)))
                                              (syntax-line lhs)
                                              (syntax-column lhs)))
                                    pats)]
@@ -2613,6 +2616,9 @@
                       (hash-map new-ht (λ (x y) y))
                       (compiled-lang-nt-map old-lang))))
 
+(define (union-language lang1 lang2)
+  (void))
+
 ;; find-primary-nt : symbol lang -> symbol or #f
 ;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language.
 (define (find-primary-nt nt lang)
@@ -2755,7 +2761,8 @@
 
 (define-for-syntax (get-srcloc stx)
   #`(list 
-     '#,(syntax-source stx)
+     '#,(and (path? (syntax-source stx))
+             (path->relative-string/library (syntax-source stx)))
      '#,(syntax-line stx)
      '#,(syntax-column stx)
      '#,(syntax-position stx)))
@@ -2909,9 +2916,7 @@
         [pos (list-ref srcinfo 3)])
     (eprintf "FAILED ~a~a\n"
              (cond
-               [(path? file) 
+               [(string? file) file]
-                (let-values ([(base name dir) (split-path file)])
-                  (path->string name))]
                [else ""])
              (cond
                [(and line column)

collects/redex/private/rewrite-side-conditions.rkt

@@ -3,6 +3,7 @@
   (require mzlib/list
            "underscore-allowed.rkt")
   (require "term.rkt"
+           setup/path-to-relative
            (for-template
             mzscheme
             "term.rkt"
@@ -88,8 +89,20 @@
                                               name/ellipses)))
                                   pre-vars
                                   names/ellipses))]
-                           [src-loc (parameterize ([print-syntax-width 0])
+                           [src-loc 
-                                      (format "~s" #'exp))])
+                            (let ([stx #'exp])
+                              (define src (syntax-source stx))
+                              (define line (syntax-line stx))
+                              (define col (syntax-column stx))
+                              (format "~a:~a" 
+                                      (if (path? src)
+                                          (path->relative-string/library src)
+                                          "?")
+                                      (if (and line col)
+                                          (format "~a:~a" line col)
+                                          (if line
+                                              (format "~a:?" line)
+                                              (syntax-position stx)))))])
                (values (syntax/loc term
                          (side-condition
                           pre-term

collects/redex/private/rg.rkt

@@ -8,6 +8,7 @@
          "struct.rkt"
          "match-a-pattern.rkt"
          (for-syntax racket/base
+                     setup/path-to-relative
                      "rewrite-side-conditions.rkt"
                      "term-fn.rkt"
                      "reduction-semantics.rkt"
@@ -810,7 +811,7 @@
      (with-syntax ([loc (if (and (path? (syntax-source stx))
                                  (syntax-line stx))
                             (format "~a:~a"
-                                    (path->string (syntax-source stx)) 
+                                    (path->relative-string/library (syntax-source stx)) 
                                     (syntax-line stx))
                             #f)])
        #`(λ (msg)

collects/redex/private/tut.scrbl

@@ -5,7 +5,10 @@
           scribble/eval
           racket/runtime-path
           scriblib/autobib
-          (for-syntax racket/base)
+          (for-syntax racket/base 
+                      setup/path-to-relative 
+                      setup/main-collects)
+          setup/dirs
           "tut-util.rkt"
           (for-label racket/base
                      racket/gui
@@ -42,18 +45,7 @@
 @(define-for-syntax (loc stx)
    (let ([src (syntax-source stx)])
      (if (path? src)
-         (apply
+         (path->relative-string/library	src)
-          build-path
-          (reverse
-           (let loop ([src src]
-                      [i 3])
-             (cond
-               [(zero? i) '()]
-               [else
-                (define-values (base name dir) (split-path src))
-                (if base
-                    (cons name (loop base (- i 1)))
-                    (list name))]))))
          #f)))
 @(define-syntax (interaction/test stx)
    (syntax-case stx ()
@@ -484,20 +476,58 @@ relation for our @racket[amb] language, we first need to define
 the evaluation contexts and values, so we extend the
 language a second time.
 
-@racketblock+eval[#:eval
+
-                  amb-eval
+@; these definitions are just like racketblock+eval, but also
-                  (define-extended-language Ev L+Γ
+@; preserve source locations so we can show typesetting
-                    (p (e ...))
+@; examples in a later section
-                    (P (e ... E e ...))
+@(require syntax/strip-context)
-                    (E (v E) 
+@(define-syntax (m stx)
-                       (E e)
+   (syntax-case stx ()
-                       (+ v ... E e ...)
+     [(_ arg)
-                       (if0 E e e)
+      (let ()
-                       (fix E)
+        (define rewritten
-                       hole)
+          (let loop ([stx #'arg])
-                    (v (λ (x t) e)
+            (cond
-                       (fix v)
+              [(syntax? stx) #`(datum->syntax #f
-                       number))]
+                                              #,(loop (syntax-e stx))
+                                              (vector (convert-to-path 
+                                                       '#,(and (path? (syntax-source stx))
+                                                               (path->main-collects-relative (syntax-source stx))))
+                                                      #,(syntax-line stx)
+                                                      #,(syntax-column stx)
+                                                      #,(syntax-position stx)
+                                                      #,(syntax-span stx)))]
+              [(pair? stx) #`(cons #,(loop (car stx))
+                                   #,(loop (cdr stx)))]
+              [(or (symbol? stx) (null? stx)
+                   (number? stx) (keyword? stx)
+                   (string? stx))
+               #`'#,stx]
+              [else (error 'm "unk ~s" stx)])))
+        #`(let ()
+            (amb-eval #,rewritten)
+            (racketblock arg)))]))
+@(define (convert-to-path src)
+   (cond
+     [(path? src) src]
+     [(not src) src]
+     [else
+      (apply build-path
+             (find-collects-dir) 
+             (map bytes->path (cdr src)))]))
+
+@m[(define-extended-language Ev L+Γ
+     (p (e ...))
+     (P (e ... E e ...))
+     (E (v E) 
+        (E e)
+        (+ v ... E e ...)
+        (if0 E e e)
+        (fix E)
+        hole)
+     (v (λ (x t) e)
+        (fix v)
+        number))]
 
 To give a suitable notion of evaluation for @racket[amb], we define
 @racket[p], a non-terminal for programs. Each program consists of a
@@ -576,35 +606,6 @@ supply directly to @racket[subst/proc]).
 
 Using that substitution function, we can now give the reduction relation.
 
-@; these definitions are just like racketblock+eval, but also
-@; preserve source locations so we can show typesetting
-@; examples in a later section
-@(require syntax/strip-context)
-@(define-syntax (m stx)
-   (syntax-case stx ()
-     [(_ arg)
-      (let ()
-        (define rewritten
-          (let loop ([stx #'arg])
-            (cond
-              [(syntax? stx) #`(datum->syntax #f
-                                              #,(loop (syntax-e stx))
-                                              (vector #,(syntax-source stx)
-                                                      #,(syntax-line stx)
-                                                      #,(syntax-column stx)
-                                                      #,(syntax-position stx)
-                                                      #,(syntax-span stx)))]
-              [(pair? stx) #`(cons #,(loop (car stx))
-                                   #,(loop (cdr stx)))]
-              [(or (symbol? stx) (null? stx)
-                   (number? stx) (keyword? stx)
-                   (string? stx))
-               #`'#,stx]
-              [else (error 'm "unk ~s" stx)])))
-        #`(let ()
-            (amb-eval #,rewritten)
-            (racketblock arg)))]))
-
 @m[(define red
      (reduction-relation
       Ev
@@ -1026,6 +1027,27 @@ a different set of strings and @racket[lw]s. For more details on the structure o
 
 @exercise[]
 
+Redex uses the indentation and newlines in the program source code to
+determine where the line breaks in the printed output goes, instead of
+using a pretty-printer, so as to give Redex programmers fine-grained
+control over how their models typeset.
+
+Exploit this facility so that this expression produces an expression
+with a minimum amount of whitespace within its bounding box.
+(The call to @racket[frame] helps to clarify where the bounding
+box is.)
+
+@racketblock[(frame
+              (vl-append
+               20
+               (language->pict Ev)
+               (reduction-relation->pict red)))]
+
+That is, adjust the whitespace in @racket[Ev] so that it
+fills as much of the width established by rendering @racket[red].
+
+@exercise[]
+
 Typeset @racket[types]. Use a compound rewriter so a use of @racket[(type Γ e t)]
 is rendered as @racketblock[Γ ⊢ e : t]
 

collects/redex/tests/check-syntax-test.rkt

@@ -3,7 +3,9 @@
 (require "test-util.rkt"
          drracket/check-syntax
          redex/pict
-         redex/reduction-semantics)
+         redex/reduction-semantics
+         (for-syntax setup/path-to-relative)
+         setup/path-to-relative)
 
 (reset-count)
 
@@ -18,10 +20,13 @@
           #,(syntax-line #'x)
           #,(syntax-column #'x)
           #,(syntax-position #'x))
-         (read-syntax '#,(syntax-source #'x) p))]))
+         (read-syntax '#,(and (path? (syntax-source #'x))
+                              (path->relative-string/library (syntax-source #'x)))
+                      p))]))
 
 (define (source stx)
-  (list (syntax-source stx)
+  (list (and (path? (syntax-source stx))
+             (path->relative-string/library (syntax-source stx)))
         (syntax-line stx)
         (syntax-column stx)))
 

collects/redex/tests/test-util.rkt

@@ -1,9 +1,10 @@
 #lang scheme
 
 (require "../private/matcher.rkt"
-         (for-syntax syntax/parse)
+         (for-syntax syntax/parse setup/path-to-relative)
          errortrace/errortrace-lib
          errortrace/errortrace-key
+         setup/path-to-relative
          racket/runtime-path)
 (provide test test-syn-err tests reset-count
          syn-err-test-namespace
@@ -31,7 +32,7 @@
     [(_ expected got)
      (with-syntax ([line (syntax-line stx)]
                    [fn (if (path? (syntax-source (syntax got)))
-                           (path->string (syntax-source (syntax got)))
+                           (path->relative-string/library (syntax-source (syntax got)))
                            "<unknown file>")])
        (syntax/loc stx (test/proc (λ () expected) got line fn)))]))
 
@@ -74,7 +75,8 @@
     [(message named-pieces body)
      (make-error-test (syntax/loc spec (message named-pieces () body)))]
     [(message ([loc-name loc-piece] ...) ([non-loc-name non-loc-piece] ...) body)
-     (values (syntax-source spec)
+     (values (and (path? (syntax-source spec))
+                  (path->relative-string/library (syntax-source spec)))
              (syntax-line spec)
              (syntax-e #'message)
              (map source-location (syntax->list #'(loc-piece ...)))
@@ -87,7 +89,8 @@
                  (void)))]))
 
 (define (source-location stx)
-  (list (syntax-source stx) 
+  (list (and (path? (syntax-source stx))
+             (path->relative-string/library (syntax-source stx))) 
         (syntax-line stx) 
         (syntax-column stx) 
         (syntax-position stx)