suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added contracts back

Browse Source 
svn: r11535
This commit is contained in:
Robby Findler 2008-09-04 12:09:18 +00:00
parent 27d6d97917
commit 5e963dccea
1 changed files with 63 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
collects/syntax/modresolve.ss
View File

@ -1,80 +1,77 @@
(module modresolve mzscheme
(require mzlib/list
"private/modhelp.ss")
#lang scheme/base
(require scheme/contract
"private/modhelp.ss")
(define (force-relto relto dir?)
(cond [(path-string? relto)
(if dir?
(define (force-relto relto dir?)
(cond [(path-string? relto)
(if dir?
(let-values ([(base n d?) (split-path relto)])
(if (eq? base 'relative)
(or (current-load-relative-directory) (current-directory))
base))
(or (current-load-relative-directory) (current-directory))
base))
relto)]
[(pair? relto) relto]
[(not dir?)
(error 'resolve-module-path-index
"can't resolve \"self\" with non-path relative-to: ~e" relto)]
[(procedure? relto) (relto)]
[else (current-directory)]))
[(pair? relto) relto]
[(not dir?)
(error 'resolve-module-path-index
"can't resolve \"self\" with non-path relative-to: ~e" relto)]
[(procedure? relto) (relto)]
[else (current-directory)]))
(define (resolve-module-path s relto)
;; relto should be a complete path, #f, or procedure that returns a
;; complete path
(define (get-dir) (force-relto relto #t))
(cond [(symbol? s)
;; use resolver handler:
(resolved-module-path-name
(module-path-index-resolve
(module-path-index-join s #f)))]
[(string? s)
;; Parse Unix-style relative path string
(apply build-path (get-dir) (explode-relpath-string s))]
[(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
#f]
[(or (path? s) (eq? (car s) 'file))
(let ([p (if (path? s) s (cadr s))])
(path->complete-path
p (let ([d (get-dir)])
(if (path-string? d)
(define (resolve-module-path s relto)
;; relto should be a complete path, #f, or procedure that returns a
;; complete path
(define (get-dir) (force-relto relto #t))
(cond [(symbol? s)
;; use resolver handler:
(resolved-module-path-name
(module-path-index-resolve
(module-path-index-join s #f)))]
[(string? s)
;; Parse Unix-style relative path string
(apply build-path (get-dir) (explode-relpath-string s))]
[(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
#f]
[(or (path? s) (eq? (car s) 'file))
(let ([p (if (path? s) s (cadr s))])
(path->complete-path
p (let ([d (get-dir)])
(if (path-string? d)
d
(or (current-load-relative-directory)
(current-directory))))))]
[(or (eq? (car s) 'lib)
(eq? (car s) 'quote)
(eq? (car s) 'planet))
;; use resolver handler in this case, too:
(resolved-module-path-name
(module-path-index-resolve
(module-path-index-join s #f)))]
[else #f]))
[(or (eq? (car s) 'lib)
(eq? (car s) 'quote)
(eq? (car s) 'planet))
;; use resolver handler in this case, too:
(resolved-module-path-name
(module-path-index-resolve
(module-path-index-join s #f)))]
[else #f]))
(define (resolve-module-path-index mpi relto)
;; relto must be a complete path
(let-values ([(path base) (module-path-index-split mpi)])
(if path
(define (resolve-module-path-index mpi relto)
;; relto must be a complete path
(let-values ([(path base) (module-path-index-split mpi)])
(if path
(resolve-module-path path (resolve-possible-module-path-index base relto))
(force-relto relto #f))))
(define (resolve-possible-module-path-index base relto)
(cond [(module-path-index? base)
(resolve-module-path-index base relto)]
[(and (resolved-module-path? base)
(path? (resolved-module-path-name base)))
(resolved-module-path-name base)]
[relto relto]
[else #f]))
(define (resolve-possible-module-path-index base relto)
(cond [(module-path-index? base)
(resolve-module-path-index base relto)]
[(and (resolved-module-path? base)
(path? (resolved-module-path-name base)))
(resolved-module-path-name base)]
[relto relto]
[else #f]))
(provide resolve-module-path-index
resolve-module-path)
#;
(begin
(define rel-to-path-string/thunk/#f
(or/c path-string? (-> path-string?) false/c))
(provide/contract
[resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
. -> . (or/c path? symbol?))]
[resolve-module-path-index ((or/c symbol? module-path-index?)
rel-to-path-string/thunk/#f
. -> . (or/c path? symbol?))])))
(define rel-to-path-string/thunk/#f
(or/c path-string? (-> path-string?) false/c))
(provide/contract
[resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
. -> . (or/c path? symbol?))]
[resolve-module-path-index ((or/c symbol? module-path-index?)
rel-to-path-string/thunk/#f
. -> . (or/c path? symbol?))])