From 5cd3ef8cd81538dca634cd6037d08bdfbc0c4adc Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Tue, 10 May 2011 21:28:28 -0400
Subject: [PATCH] trying to parse modules

---
 parse-bytecode-5.1.1.rkt      | 20 ++++--------
 test-parse-bytecode-5.1.1.rkt |  5 +++
 typed-module-path.rkt         | 59 +++++++++++++++++++++++++++++++++++
 3 files changed, 70 insertions(+), 14 deletions(-)
 create mode 100644 typed-module-path.rkt

diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt
index 7f7671e..c4f926b 100644
--- a/parse-bytecode-5.1.1.rkt
+++ b/parse-bytecode-5.1.1.rkt
@@ -14,20 +14,12 @@
          reset-lam-label-counter!/unit-testing)
 
 
-;; The module-path-index of self is:
-(define self-idx (module-path-index-join #f #f))
 
-(define (self-idx? mpi)
-  (let-values ([(path subpath)
-                (module-path-index-split mpi)])
-    (eq? path #f)))
-
-
-;; current-module-path-index-resolver: (module-path-index -> ModuleName) -> void
+;; current-module-path-index-resolver: (module-path-index ModuleName -> ModuleName) -> void
 ;; The module path index resolver figures out how to translate module path indices to module names.
 (define current-module-path-index-resolver 
   (make-parameter 
-   (lambda (an-mpi)
+   (lambda (mpi relative-to)
      (error 'current-module-path-index-resolver))))
 
 
@@ -124,7 +116,7 @@
     [(module-variable? a-toplevel)
      (let ([resolver (current-module-path-index-resolver)])
        (make-ModuleVariable (module-variable-sym a-toplevel)
-                            (resolver self-idx (module-variable-modidx a-toplevel))))]))
+                            (resolver (module-variable-modidx a-toplevel) #f)))]))
 
 
 ;; parse-form: form -> (U Expression)
@@ -211,12 +203,11 @@
     [(struct mod (name srcname self-modidx prefix provides requires
        body syntax-body unexported max-let-depth dummy lang-info
        internal-context))
-     (let ([resolver (current-module-path-index-resolver)])
        (make-Module (make-ModuleName name)
                     (parse-prefix prefix)
                     (parse-mod-requires self-modidx requires)
                     (parse-mod-provides provides)
-                    (parse-mod-body body)))]))
+                    (parse-mod-body body))]))
 
 
 ;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName)
@@ -229,7 +220,8 @@
          empty]
         [(= (car (first requires))
               0)
-         (map (lambda (m) (resolver enclosing-module-path-index m))
+         (map (lambda (m) (resolver m 
+                                    (resolver enclosing-module-path-index #f)))
               (cdr (first requires)))]
         [else
          (loop (rest requires))]))))
diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt
index e034275..ef48c86 100644
--- a/test-parse-bytecode-5.1.1.rkt
+++ b/test-parse-bytecode-5.1.1.rkt
@@ -308,6 +308,11 @@
                                            (make-App (make-ToplevelRef 0 1) '())))))
 
 
+;; Compiling modules
+(run-my-parse #'(module foo racket/base
+                  42))
+
+
 
 ;; make sure we don't see an infinite loop
 #;(run-zo-parse #'(letrec ([g (lambda () (g))])
diff --git a/typed-module-path.rkt b/typed-module-path.rkt
new file mode 100644
index 0000000..7f425ea
--- /dev/null
+++ b/typed-module-path.rkt
@@ -0,0 +1,59 @@
+#lang typed/racket/base
+
+(define-type RelativeString String)
+(define-type UserString String)
+(define-type PackageString String)
+
+
+
+(define-type ResolvedModulePath (U Path Symbol))
+
+(define-type ModulePath (U (List 'quote Symbol)
+                           RelativeString
+                           (Pairof 'lib (Pairof RelativeString (Listof RelativeString)))
+                           Symbol
+                           (List 'file String)
+                           (List 'planet Symbol)
+                           (List 'planet String)
+                           (Pairof 'planet 
+                                   (Pairof RelativeString
+                                           (Pairof (U (List UserString PackageString)
+                                                      (List UserString PackageString Natural)
+                                                      (List UserString PackageString Natural MinorVersion))
+                                                   (Listof RelativeString))))))
+                                            
+
+(define-type MinorVersion (U Natural
+                             (List Natural Natural)
+                             (List '= Natural)
+                             (List '+ Natural)
+                             (List '- Natural)))
+
+
+(require/typed racket/base                       
+               
+               [opaque ModulePathIndex module-path-index?]
+                        
+               [module-path-index-resolve 
+                (ModulePathIndex -> Path-String)]
+               
+               [module-path-index-join
+                ((U ModulePath #f)
+                 (U ModulePathIndex ResolvedModulePath #f) ->
+                 ModulePathIndex)]
+               
+               [module-path-index-split 
+                (ModulePathIndex -> (values (U ModulePath #f)
+                                            (U ModulePathIndex ResolvedModulePath #f)))])
+                                            
+
+
+(provide 
+ 
+ ModulePath
+ ResolvedModulePath
+         
+ ModulePathIndex
+ module-path-index-resolve
+ module-path-index-join
+ module-path-index-split)