From 651f43777efde955f63f8e0818a626143fb75736 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz 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