From 2bb4666645e83363ce0c657e1d475ee9dc12386e Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Fri, 13 May 2011 14:50:25 -0400
Subject: [PATCH] added in a path rewriter

---
 compiler.rkt                  |  1 +
 expression-structs.rkt        |  3 ++-
 parse-bytecode-5.1.1.rkt      | 30 ++++++++++++++++++++++--------
 path-rewriter.rkt             | 29 +++++++++++++++--------------
 test-parse-bytecode-5.1.1.rkt |  6 ++++--
 5 files changed, 44 insertions(+), 25 deletions(-)

diff --git a/compiler.rkt b/compiler.rkt
index 95e2684..35add10 100644
--- a/compiler.rkt
+++ b/compiler.rkt
@@ -2081,6 +2081,7 @@
     
     [(Module? exp)
      (make-Module (Module-name exp)
+                  (Module-path exp)
                   (Module-prefix exp)
                   (Module-requires exp)
                   (Module-provides exp)
diff --git a/expression-structs.rkt b/expression-structs.rkt
index 5b0b1b9..5d1b78e 100644
--- a/expression-structs.rkt
+++ b/expression-structs.rkt
@@ -36,7 +36,8 @@
                           [src-name : Symbol])
   #:transparent)
 
-(define-struct: Module ([name : ModuleName]
+(define-struct: Module ([name : Symbol]
+                        [path : ModuleName]
                         [prefix : Prefix]
                         [requires : (Listof ModuleName)]
                         [provides : (Listof Provided)]
diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt
index 537bd82..50b1315 100644
--- a/parse-bytecode-5.1.1.rkt
+++ b/parse-bytecode-5.1.1.rkt
@@ -3,6 +3,7 @@
 (require "expression-structs.rkt"
          "lexical-structs.rkt"
          "typed-module-path.rkt"
+         "path-rewriter.rkt"
          syntax/modresolve)
 
 
@@ -151,9 +152,8 @@
     [(symbol? resolved-path-name)
      (make-ModuleName resolved-path-name)]
     [(path? resolved-path-name)
-     (make-ModuleName 
-      (string->symbol
-       (path->string resolved-path-name)))]))
+     (make-ModuleName (rewrite-path resolved-path-name))]))
+
 
 
 ;; parse-form: form -> (U Expression)
@@ -240,11 +240,25 @@
     [(struct mod (name srcname self-modidx prefix provides requires
        body syntax-body unexported max-let-depth dummy lang-info
        internal-context))
-       (make-Module (make-ModuleName name)
-                    (parse-prefix prefix)
-                    (parse-mod-requires self-modidx requires)
-                    (parse-mod-provides provides)
-                    (parse-mod-body body))]))
+     (let ([self-path 
+            ((current-module-path-index-resolver)
+             self-modidx
+             (current-module-path))])
+       (cond
+        [(symbol? self-path)
+         (make-Module name
+                      (make-ModuleName self-path)
+                      (parse-prefix prefix)
+                      (parse-mod-requires self-modidx requires)
+                      (parse-mod-provides provides)
+                      (parse-mod-body body))]
+        [else
+         (make-Module name
+                      (make-ModuleName (rewrite-path self-path))
+                      (parse-prefix prefix)
+                      (parse-mod-requires self-modidx requires)
+                      (parse-mod-provides provides)
+                      (parse-mod-body body))]))]))
 
 
 ;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName)
diff --git a/path-rewriter.rkt b/path-rewriter.rkt
index fc20bba..8195dff 100644
--- a/path-rewriter.rkt
+++ b/path-rewriter.rkt
@@ -21,21 +21,22 @@
 ;; Paths located within collects get remapped to collects/....
 
 
-;; rewrite-path: complete-path -> (symbol #f)
+;; rewrite-path: path -> (symbol #f)
 (define (rewrite-path a-path)
-  (cond
-   [(within-collects? a-path)
-    (string->symbol
-     (string-append "collects/"
-                    (path->string
-                     (find-relative-path collects a-path))))]
-   [(within-root? a-path)
-    (string->symbol
-     (string-append "root/"
-                    (path->string
-                     (find-relative-path (current-root-path) a-path))))]
-   [else 
-    #f]))
+  (let ([a-path (normalize-path a-path)])
+    (cond
+     [(within-collects? a-path)
+      (string->symbol
+       (string-append "collects/"
+                      (path->string
+                       (find-relative-path collects a-path))))]
+     [(within-root? a-path)
+      (string->symbol
+       (string-append "root/"
+                      (path->string
+                       (find-relative-path (current-root-path) a-path))))]
+     [else 
+      #f])))
 
 
 (define collects
diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt
index 429a958..842e311 100644
--- a/test-parse-bytecode-5.1.1.rkt
+++ b/test-parse-bytecode-5.1.1.rkt
@@ -331,7 +331,8 @@
  (match (run-my-parse #'(module foo racket/base
                           42))
    [(struct Top ((struct Prefix (list))
-                 (struct Module ((? ModuleName?)
+                 (struct Module ((? symbol?)
+                                 (? ModuleName?)
                                  (? Prefix?) ;; the prefix will include a reference to print-values.
                                  _  ;; requires
                                  _  ;; provides
@@ -345,7 +346,8 @@
                           (provide x)
                           (define x "x")))
    [(struct Top ((struct Prefix ((? list?)))
-                 (struct Module ((? ModuleName?)
+                 (struct Module ((? symbol?)
+                                 (? ModuleName?)
                                  (? Prefix?) ;; the prefix will include a reference to print-values.
                                  _  ;; requires
                                  (list (struct Provided ('x 'x)))  ;; provides