From 651f43777efde955f63f8e0818a626143fb75736 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Thu, 10 Jun 2010 03:27:22 +0200
Subject: Racket: improvements in module lookups.

   - We now correctly register submodules and handle main files.
   - We contemplate the possibility that a module is accessed using
     different paths.
---
 scheme/racket/geiser/enter.rkt   | 48 +++++++++++++++++++++++++++++++++++-----
 scheme/racket/geiser/modules.rkt | 47 +++++++++++++++++++--------------------
 2 files changed, 66 insertions(+), 29 deletions(-)

diff --git a/scheme/racket/geiser/enter.rkt b/scheme/racket/geiser/enter.rkt
index 9705ec3..dbad12b 100644
--- a/scheme/racket/geiser/enter.rkt
+++ b/scheme/racket/geiser/enter.rkt
@@ -12,11 +12,12 @@
 #lang racket/base
 
 (require syntax/modcode
-         (for-syntax scheme/base))
+         (for-syntax racket/base)
+         racket/path)
 
 (provide get-namespace enter-module module-loader module-loaded?)
 
-(struct mod (name timestamp depends))
+(struct mod (name load-path timestamp depends))
 
 (define loaded (make-hash))
 
@@ -39,8 +40,44 @@
 (define inhibit-eval (make-parameter #f))
 
 (define (get-namespace mod)
-  (parameterize ([inhibit-eval #t])
-    (module->namespace mod)))
+  (let ([mod (cond [(symbol? mod) mod]
+                   [(string? mod) (find-module! (string->path mod) mod)]
+                   [(path? mod) (find-module! mod (path->string mod))]
+                   [else mod])])
+    (and mod
+         (with-handlers ([exn? (lambda (_) #f)])
+           (parameterize ([inhibit-eval #t])
+             (module->namespace mod))))))
+
+(define (find-module! path path-str)
+  (let ([m (or (hash-ref loaded path #f)
+               (let loop ([ps (remove path (resolve-paths path))]
+                          [seen '()])
+                 (cond [(null? ps) #f]
+                       [(hash-ref loaded (car ps) #f) =>
+                        (lambda (m)
+                          (add-paths! m (cdr ps))
+                          (add-paths! m (cons path seen))
+                          m)]
+                       [else (loop (cdr ps) (cons (car ps) seen))])))])
+    (list 'file (or (and m (mod-load-path m)) path-str))))
+
+(define (add-paths! m ps)
+  (for-each (lambda (p) (hash-set! loaded p m)) ps))
+
+(define (resolve-paths path)
+  (define (find root rest)
+    (let* ([alt-root (resolve-path root)]
+           [same? (equal? root alt-root)])
+      (cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
+            [else (let* ([c (car rest)]
+                         [cs (cdr rest)]
+                         [rps (find (build-path root c) cs)])
+                    (if same?
+                        rps
+                        (append rps (find (build-path alt-root c) cs))))])))
+  (let ([cmps (explode-path path)])
+    (find (car cmps) (cdr cmps))))
 
 (define ((enter-load/use-compiled orig re?) path name)
   (when (inhibit-eval)
@@ -61,13 +98,14 @@
                                              (current-directory)))))])
         ;; Record module timestamp and dependencies:
         (let ([m (mod name
+                      (path->string path)
                       (get-timestamp path)
                       (if code
                           (apply append
                                  (map cdr
                                       (module-compiled-imports code)))
                           null))])
-          (hash-set! loaded path m))
+          (add-paths! m (resolve-paths path)))
         ;; Evaluate the module:
         (eval code))
       ;; Not a module:
diff --git a/scheme/racket/geiser/modules.rkt b/scheme/racket/geiser/modules.rkt
index 5022891..0ab372a 100644
--- a/scheme/racket/geiser/modules.rkt
+++ b/scheme/racket/geiser/modules.rkt
@@ -27,17 +27,15 @@
         [(not (string? spec)) #f]
         [else `(file ,spec)]))
 
-(define (module-spec->namespace spec (lang #f) (no-current #f))
-  (let ([spec (ensure-module-spec spec)]
-        [try-lang (lambda (_)
-                    (with-handlers ([exn? (const (current-namespace))])
-                      (and lang
-                           (begin
-                             (load-module lang #f (current-namespace))
-                             (module->namespace lang)))))])
-    (or (and spec
-             (with-handlers ([exn? try-lang]) (get-namespace spec)))
-        (if no-current #f (current-namespace)))))
+(define (module-spec->namespace spec (lang #f) (current #t))
+  (define (try-lang)
+    (and lang
+         (with-handlers ([exn? (const #f)])
+           (load-module lang #f (current-namespace))
+           (module->namespace lang))))
+  (or (get-namespace spec)
+      (try-lang)
+      (and current (current-namespace))))
 
 (define nowhere (open-output-nowhere))
 
@@ -58,7 +56,7 @@
        (or (get-path spec)
            (register-path spec
                           (namespace->module-path-name
-                           (module-spec->namespace spec) #f #t)))))
+                           (module-spec->namespace spec) #f #f)))))
 
 (define (module-path-name->name path)
   (cond [(path? path)
@@ -92,24 +90,25 @@
   (let ([ext (filename-extension path)])
     (and ext
          (or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
+         (not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
          (let* ([path (path->string path)]
                 [len (- (string-length path) (bytes-length ext) 1)])
            (substring path 0 len)))))
 
 (define (visit-module-path path kind acc)
+  (define (register e p)
+    (register-path (string->symbol e) (build-path (current-directory) p))
+    (cons e acc))
+  (define (find-main ext)
+    (let ([m (build-path path (string-append "main." ext))])
+      (and (file-exists? m) m)))
   (case kind
-    [(file) (let ((entry (path->entry path)))
-              (if (not entry)
-                  acc
-                  (begin
-                    (register-path (string->symbol entry)
-                                   (build-path (current-directory) path))
-                    (cons entry acc))))]
-    [(dir) (cond ((skippable-dir? path) (values acc #f))
-                 ((or (file-exists? (build-path path "main.rkt"))
-                      (file-exists? (build-path path "main.ss")))
-                  (cons (path->string path) acc))
-                 (else acc))]
+    [(file) (let ([entry (path->entry path)])
+              (if (not entry) acc (register entry path)))]
+    [(dir) (cond [(skippable-dir? path) (values acc #f)]
+                 [(or (find-main "rkt") (find-main "ss")) =>
+                  (curry register (path->string path))]
+                 [else acc])]
     [else acc]))
 
 (define (find-modules path acc)
-- 
cgit v1.2.3