code cleanup etc
svn: r5401
This commit is contained in:
Eli Barzilay
parent
33f9bc68db
commit
b35c1ab25f
|
|
@ -1,542 +1,441 @@
|
||||||
|
|
||||||
(module moddep mzscheme
|
(module moddep mzscheme
|
||||||
(require (lib "etc.ss")
|
(require (lib "port.ss")
|
||||||
(lib "port.ss")
|
(lib "list.ss")
|
||||||
(lib "list.ss")
|
(lib "string.ss")
|
||||||
(lib "contract.ss")
|
(lib "contract.ss")
|
||||||
|
(lib "kw.ss")
|
||||||
(lib "resolver.ss" "planet"))
|
(lib "resolver.ss" "planet"))
|
||||||
|
|
||||||
|
|
||||||
(provide moddep-current-open-input-file)
|
(provide moddep-current-open-input-file)
|
||||||
(define moddep-current-open-input-file
|
(define moddep-current-open-input-file
|
||||||
(make-parameter open-input-file))
|
(make-parameter open-input-file))
|
||||||
|
|
||||||
(provide with-module-reading-parameterization)
|
(provide with-module-reading-parameterization)
|
||||||
(define (with-module-reading-parameterization thunk)
|
(define (with-module-reading-parameterization thunk)
|
||||||
(parameterize ((read-case-sensitive #t)
|
(parameterize ([read-case-sensitive #t]
|
||||||
(read-square-bracket-as-paren #t)
|
[read-square-bracket-as-paren #t]
|
||||||
(read-curly-brace-as-paren #t)
|
[read-curly-brace-as-paren #t]
|
||||||
(read-accept-box #t)
|
[read-accept-box #t]
|
||||||
(read-accept-compiled #t)
|
[read-accept-compiled #t]
|
||||||
(read-accept-bar-quote #t)
|
[read-accept-bar-quote #t]
|
||||||
(read-accept-graph #t)
|
[read-accept-graph #t]
|
||||||
(read-decimal-as-inexact #t)
|
[read-decimal-as-inexact #t]
|
||||||
(read-accept-dot #t)
|
[read-accept-dot #t]
|
||||||
(read-accept-quasiquote #t)
|
[read-accept-quasiquote #t]
|
||||||
(read-accept-reader #t)
|
[read-accept-reader #t]
|
||||||
(current-readtable #f))
|
[current-readtable #f])
|
||||||
(thunk)))
|
(thunk)))
|
||||||
|
|
||||||
(define (raise-wrong-module-name filename expected-name name)
|
(define (raise-wrong-module-name filename expected-name name)
|
||||||
(raise
|
(error 'load-handler
|
||||||
(make-exn:fail
|
"expected a `module' declaration for `~a' in ~s, found: ~a"
|
||||||
(format
|
expected-name filename name))
|
||||||
"load-handler: expected a `module' declaration for `~a' in ~s, found: ~a"
|
|
||||||
expected-name filename name)
|
|
||||||
(current-continuation-marks))))
|
|
||||||
|
|
||||||
(define (check-module-form exp expected-module filename)
|
(define (check-module-form exp expected-module filename)
|
||||||
(cond
|
(cond [(or (eof-object? exp) (eof-object? (syntax-e exp)))
|
||||||
[(or (eof-object? exp)
|
(and filename
|
||||||
(eof-object? (syntax-e exp)))
|
(error 'load-handler
|
||||||
(and filename
|
"expected a `module' declaration for `~a' in ~s, but found end-of-file"
|
||||||
(raise
|
expected-module filename))]
|
||||||
(make-exn:fail
|
[(compiled-module-expression? (syntax-e exp))
|
||||||
(format
|
(if (eq? (module-compiled-name (syntax-e exp)) expected-module)
|
||||||
"load-handler: expected a `module' declaration for `~a' in ~s, but found end-of-file"
|
;; It's fine:
|
||||||
expected-module filename)
|
exp
|
||||||
(current-continuation-marks))))]
|
;; Wrong name:
|
||||||
[(compiled-module-expression? (syntax-e exp))
|
(and filename (raise-wrong-module-name
|
||||||
(if (eq? (module-compiled-name (syntax-e exp))
|
filename expected-module
|
||||||
expected-module)
|
(module-compiled-name (syntax-e exp)))))]
|
||||||
;; It's fine:
|
[(and (syntax? exp)
|
||||||
exp
|
(syntax-case exp ()
|
||||||
;; Wrong name:
|
[(mod nm . _)
|
||||||
(and filename
|
(and (eq? (syntax-e #'mod) 'module) (identifier? #'nm))]
|
||||||
(raise-wrong-module-name filename expected-module
|
[_else #f]))
|
||||||
(module-compiled-name (syntax-e exp)))))]
|
;; It's ok; need to install a specific `module' binding:
|
||||||
[(and (syntax? exp)
|
(with-syntax ([(mod nm . _) exp])
|
||||||
(syntax-case exp ()
|
(unless (eq? (syntax-e #'nm) expected-module)
|
||||||
[(mod nm . _)
|
(raise-wrong-module-name filename expected-module
|
||||||
(and (eq? (syntax-e (syntax mod)) 'module)
|
(syntax-e #'nm)))
|
||||||
(identifier? (syntax nm)))]
|
(datum->syntax-object exp
|
||||||
[_else #f]))
|
(cons #'module (cdr (syntax-e exp)))
|
||||||
;; It's ok; need to install a specific `module' binding:
|
exp
|
||||||
(with-syntax ([(mod nm . _) exp])
|
exp))]
|
||||||
(unless (eq? (syntax-e (syntax nm)) expected-module)
|
[else
|
||||||
(raise-wrong-module-name filename expected-module (syntax-e (syntax nm))))
|
(and filename
|
||||||
(datum->syntax-object exp
|
(error 'load-handler
|
||||||
(cons (syntax module)
|
"expected a `module' declaration for `~a' in ~s, but found something else"
|
||||||
(cdr (syntax-e exp)))
|
expected-module filename))]))
|
||||||
exp
|
|
||||||
exp))]
|
|
||||||
[else
|
|
||||||
(and filename
|
|
||||||
(raise
|
|
||||||
(make-exn:fail
|
|
||||||
(format
|
|
||||||
"load-handler: expected a `module' declaration for `~a' in ~s, but found something else"
|
|
||||||
expected-module filename)
|
|
||||||
(current-continuation-marks))))]))
|
|
||||||
|
|
||||||
(define re:suffix #rx#"\\..*$")
|
|
||||||
|
|
||||||
(define (resolve s)
|
(define (resolve s)
|
||||||
(if (complete-path? s)
|
(if (complete-path? s)
|
||||||
s
|
s
|
||||||
(let ([d (current-load-relative-directory)])
|
(let ([d (current-load-relative-directory)])
|
||||||
(if d (path->complete-path s d) s))))
|
(if d (path->complete-path s d) s))))
|
||||||
|
|
||||||
(define (date>=? a bm)
|
(define (date>=? a bm)
|
||||||
(and a
|
(and a (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
||||||
(let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
(file-or-directory-modify-seconds a))])
|
||||||
(file-or-directory-modify-seconds a))])
|
(or (and (not bm) am) (and am bm (>= am bm))))))
|
||||||
(or (and (not bm) am) (and am bm (>= am bm))))))
|
|
||||||
|
|
||||||
(define (read-one path src?)
|
(define (read-one path src?)
|
||||||
(let ([p ((moddep-current-open-input-file) path)])
|
(let ([p ((moddep-current-open-input-file) path)])
|
||||||
(when src?
|
(when src? (port-count-lines! p) (strip-shell-command-start p))
|
||||||
(port-count-lines! p)
|
|
||||||
(strip-shell-command-start p))
|
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
void
|
void
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ([v (with-module-reading-parameterization
|
(let ([v (with-module-reading-parameterization
|
||||||
(lambda ()
|
(lambda () (read-syntax path p)))])
|
||||||
(read-syntax path p)))])
|
(when (eof-object? v)
|
||||||
(when (eof-object? v)
|
(error 'read-one
|
||||||
(error 'read-one "empty file; expected a module declaration in: ~a" path))
|
"empty file; expected a module declaration in: ~a" path))
|
||||||
(let* ([name (let-values ([(base name dir?) (split-path path)])
|
(let* ([name (let-values ([(base name dir?) (split-path path)])
|
||||||
(string->symbol (bytes->string/utf-8
|
(string->symbol
|
||||||
(path->bytes (path-replace-suffix name #""))
|
(bytes->string/utf-8
|
||||||
#\?)))]
|
(path->bytes (path-replace-suffix name #""))
|
||||||
[v (check-module-form v name path)])
|
#\?)))]
|
||||||
(unless (eof-object? (read p))
|
[v (check-module-form v name path)])
|
||||||
(error
|
(unless (eof-object? (read p))
|
||||||
'read-one
|
(error 'read-one
|
||||||
"file has more than one expression; expected a module declaration only in: ~a"
|
"file has more than one expression; expected a module declaration only in: ~a"
|
||||||
path))
|
path))
|
||||||
(if (and (syntax? v)
|
(if (and (syntax? v) (compiled-expression? (syntax-e v)))
|
||||||
(compiled-expression? (syntax-e v)))
|
(syntax-e v)
|
||||||
(syntax-e v)
|
v))))
|
||||||
v))))
|
(lambda () (close-input-port p)))))
|
||||||
(lambda () (close-input-port p)))))
|
|
||||||
|
|
||||||
(define-struct (exn:get-module-code exn) (path))
|
(define-struct (exn:get-module-code exn) (path))
|
||||||
|
|
||||||
(define get-module-code
|
(define/kw (get-module-code path
|
||||||
(opt-lambda (path [sub-path "compiled"] [compiler compile] [extension-handler #f])
|
#:optional
|
||||||
(unless (path-string? path)
|
[sub-path "compiled"] [compiler compile] [extension-handler #f])
|
||||||
(raise-type-error 'get-module-code "path or string (sans nul)" path))
|
(unless (path-string? path)
|
||||||
(let*-values ([(path) (resolve path)]
|
(raise-type-error 'get-module-code "path or string (sans nul)" path))
|
||||||
[(base file dir?) (split-path path)]
|
(let*-values ([(path) (resolve path)]
|
||||||
[(base) (if (eq? base 'relative) 'same base)]
|
[(base file dir?) (split-path path)]
|
||||||
[(mode) (use-compiled-file-paths)])
|
[(base) (if (eq? base 'relative) 'same base)]
|
||||||
(let* ([get-so (lambda (file)
|
[(mode) (use-compiled-file-paths)])
|
||||||
(build-path base
|
(let* ([get-so (lambda (file)
|
||||||
sub-path
|
(build-path
|
||||||
"native"
|
base sub-path "native"
|
||||||
(system-library-subpath)
|
(system-library-subpath)
|
||||||
(path-replace-suffix
|
(path-replace-suffix file (system-type 'so-suffix))))]
|
||||||
file
|
[zo (build-path base sub-path (path-replace-suffix file #".zo"))]
|
||||||
(case (system-type)
|
[so (get-so file)]
|
||||||
[(windows) #".dll"]
|
[_loader-so (get-so (string->path "_loader.ss"))]
|
||||||
[(macosx) #".dylib"]
|
[path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
||||||
[else #".so"]))))]
|
(file-or-directory-modify-seconds path))]
|
||||||
[zo (build-path base
|
[with-dir (lambda (t)
|
||||||
sub-path
|
(parameterize ([current-load-relative-directory
|
||||||
(path-replace-suffix file #".zo"))]
|
(if (path? base)
|
||||||
[so (get-so file)]
|
base
|
||||||
[_loader-so (get-so (string->path "_loader.ss"))]
|
(current-directory))])
|
||||||
[path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
(t)))])
|
||||||
(file-or-directory-modify-seconds path))]
|
(cond
|
||||||
[with-dir (lambda (t)
|
;; Use .zo, if it's new enough
|
||||||
(parameterize ([current-load-relative-directory
|
[(date>=? zo path-d) (read-one zo #f)]
|
||||||
(if (path? base)
|
;; Otherwise, use source if it exists
|
||||||
base
|
[path-d (with-dir (lambda () (compiler (read-one path #t))))]
|
||||||
(current-directory))])
|
;; No source --- maybe there's an .so?
|
||||||
(t)))])
|
[(and (not path-d) (date>=? so path-d))
|
||||||
(cond
|
(if extension-handler
|
||||||
;; Use .zo, if it's new enough
|
(extension-handler so #f)
|
||||||
[(date>=? zo path-d)
|
(raise (make-exn:get-module-code
|
||||||
(read-one zo #f)]
|
(format "get-module-code: cannot use extension file; ~e" so)
|
||||||
;; Otherwise, use source if it exists
|
(current-continuation-marks)
|
||||||
[path-d
|
so)))]
|
||||||
(with-dir (lambda () (compiler (read-one path #t))))]
|
;; Or maybe even a _loader.so?
|
||||||
;; No source --- maybe there's an .so?
|
[(and (not path-d)
|
||||||
[(and (not path-d)
|
(date>=? _loader-so path-d)
|
||||||
(date>=? so path-d))
|
(let ([getter (load-extension _loader-so)])
|
||||||
(if extension-handler
|
(let-values ([(loader modname)
|
||||||
(extension-handler so #f)
|
(getter (string->symbol
|
||||||
(raise (make-exn:get-module-code
|
(bytes->string/latin-1
|
||||||
(format "get-module-code: cannot use extension file; ~e" so)
|
(path->bytes
|
||||||
(current-continuation-marks)
|
(path-replace-suffix file #"")))))])
|
||||||
so)))]
|
loader)))
|
||||||
;; Or maybe even a _loader.so?
|
=> (lambda (loader)
|
||||||
[(and (not path-d)
|
(if extension-handler
|
||||||
(date>=? _loader-so path-d)
|
(extension-handler loader #t)
|
||||||
(let ([getter (load-extension _loader-so)])
|
(raise (make-exn:get-module-code
|
||||||
(let-values ([(loader modname) (getter (string->symbol
|
(format "get-module-code: cannot use _loader file: ~e"
|
||||||
(bytes->string/latin-1
|
_loader-so)
|
||||||
(path->bytes
|
(current-continuation-marks)
|
||||||
(path-replace-suffix file #"")))))])
|
loader))))]
|
||||||
loader)))
|
;; Report a not-there error
|
||||||
=> (lambda (loader)
|
[else (raise (make-exn:get-module-code
|
||||||
(if extension-handler
|
(format "get-module-code: no such file: ~e" path)
|
||||||
(extension-handler loader #t)
|
(current-continuation-marks)
|
||||||
(raise (make-exn:get-module-code
|
#f))]))))
|
||||||
(format "get-module-code: cannot use _loader file: ~e"
|
|
||||||
_loader-so)
|
|
||||||
(current-continuation-marks)
|
|
||||||
loader))))]
|
|
||||||
;; Report a not-there error
|
|
||||||
[else
|
|
||||||
(raise (make-exn:get-module-code
|
|
||||||
(format "get-module-code: no such file: ~e" path)
|
|
||||||
(current-continuation-marks)
|
|
||||||
#f))])))))
|
|
||||||
|
|
||||||
(define re:dir #rx#"(.+?)/+(.*)")
|
|
||||||
|
|
||||||
(define (force-relto relto dir?)
|
(define (force-relto relto dir?)
|
||||||
(cond
|
(cond [(path-string? relto)
|
||||||
[(path-string? relto)
|
(if dir?
|
||||||
(if dir?
|
(let-values ([(base n d?) (split-path relto)])
|
||||||
(let-values ([(base n d?) (split-path relto)])
|
(if (eq? base 'relative)
|
||||||
(if (eq? base 'relative)
|
(or (current-load-relative-directory) (current-directory))
|
||||||
(or (current-load-relative-directory)
|
base))
|
||||||
(current-directory))
|
relto)]
|
||||||
base))
|
[(pair? relto) relto]
|
||||||
relto)]
|
[(not dir?)
|
||||||
[(pair? relto) relto]
|
(error 'resolve-module-path-index
|
||||||
[(not dir?)
|
"can't resolve \"self\" with non-path relative-to: ~e" relto)]
|
||||||
(error 'resolve-module-path-index "can't resolve \"self\" with non-path relative-to: ~e" relto)]
|
[(procedure? relto) (relto)]
|
||||||
[(procedure? relto) (relto)]
|
[else (current-directory)]))
|
||||||
[else
|
|
||||||
(current-directory)]))
|
|
||||||
|
|
||||||
(define resolve-module-path
|
(define (explode-relpath-string p)
|
||||||
;; relto should be a complete path, #f, or procedure that returns a complete path
|
(map (lambda (p)
|
||||||
(lambda (s relto)
|
(cond [(assoc p '((#"." . same) (#".." . up))) => cdr]
|
||||||
(let ([get-dir (lambda () (force-relto relto #t))])
|
[else (bytes->path p)]))
|
||||||
(cond
|
(regexp-split #rx#"/+" (string->bytes/utf-8 p))))
|
||||||
[(string? s)
|
|
||||||
;; Parse Unix-style relative path string
|
(define (resolve-module-path s relto)
|
||||||
(let loop ([path (get-dir)][s (if (path? s)
|
;; relto should be a complete path, #f, or procedure that returns a
|
||||||
(path->bytes s)
|
;; complete path
|
||||||
(string->bytes/utf-8 s))])
|
(define (get-dir) (force-relto relto #t))
|
||||||
(let ([prefix (regexp-match re:dir s)])
|
(cond [(string? s)
|
||||||
(if prefix
|
;; Parse Unix-style relative path string
|
||||||
(loop (build-path path
|
(apply build-path (get-dir) (explode-relpath-string s))]
|
||||||
(let ([p (cadr prefix)])
|
[(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
|
||||||
(cond
|
#f]
|
||||||
[(bytes=? p #".") 'same]
|
[(or (path? s) (eq? (car s) 'file))
|
||||||
[(bytes=? p #"..") 'up]
|
(let ([p (if (path? s) s (cadr s))])
|
||||||
[else (bytes->path p)])))
|
(path->complete-path
|
||||||
(caddr prefix))
|
p (let ([d (get-dir)])
|
||||||
(build-path path (bytes->path s)))))]
|
(if (path-string? d)
|
||||||
[(and (or (not (pair? s))
|
d
|
||||||
(not (list? s)))
|
(or (current-load-relative-directory)
|
||||||
(not (path? s)))
|
(current-directory))))))]
|
||||||
#f]
|
[(eq? (car s) 'lib)
|
||||||
[(or (path? s)
|
(let* ([cols (let ([len (length s)])
|
||||||
(eq? (car s) 'file))
|
(if (= len 2) (list "mzlib") (cddr s)))]
|
||||||
(let ([p (if (path? s)
|
[p (apply collection-path cols)])
|
||||||
s
|
(build-path p (cadr s)))]
|
||||||
(cadr s))])
|
[(eq? (car s) 'planet)
|
||||||
(path->complete-path p (let ([d (get-dir)])
|
(let ([module-id
|
||||||
(if (path-string? d)
|
(and (path? relto)
|
||||||
d
|
(string->symbol
|
||||||
(or (current-load-relative-directory)
|
(string-append
|
||||||
(current-directory))))))]
|
"," (path->string (path->complete-path relto)))))])
|
||||||
[(eq? (car s) 'lib)
|
(let-values ([(path pkg)
|
||||||
(let ([cols (let ([len (length s)])
|
(get-planet-module-path/pkg s module-id #f)])
|
||||||
(if (= len 2)
|
path))]
|
||||||
(list "mzlib")
|
[else #f]))
|
||||||
(cddr s)))])
|
|
||||||
(let ([p (apply collection-path cols)])
|
|
||||||
(build-path p (cadr s))))]
|
|
||||||
[(eq? (car s) 'planet)
|
|
||||||
(let ((module-id
|
|
||||||
(cond
|
|
||||||
[(path? relto)
|
|
||||||
(string->symbol (string-append "," (path->string (path->complete-path relto))))]
|
|
||||||
[else #f])))
|
|
||||||
(let-values ([(path pkg) (get-planet-module-path/pkg s module-id #f)])
|
|
||||||
path))]
|
|
||||||
[else #f]))))
|
|
||||||
|
|
||||||
(define (resolve-module-path-index mpi relto)
|
(define (resolve-module-path-index mpi relto)
|
||||||
;; relto must be a complete path
|
;; relto must be a complete path
|
||||||
(let-values ([(path base) (module-path-index-split mpi)])
|
(let-values ([(path base) (module-path-index-split mpi)])
|
||||||
(if path
|
(if path
|
||||||
(resolve-module-path path (resolve-possible-module-path-index base relto))
|
(resolve-module-path path (resolve-possible-module-path-index base relto))
|
||||||
(force-relto relto #f))))
|
(force-relto relto #f))))
|
||||||
|
|
||||||
(define (resolve-possible-module-path-index base relto)
|
(define (resolve-possible-module-path-index base relto)
|
||||||
(cond
|
(cond [(module-path-index? base)
|
||||||
[(module-path-index? base)
|
(resolve-module-path-index base relto)]
|
||||||
(resolve-module-path-index base relto)]
|
[(symbol? base)
|
||||||
[(symbol? base)
|
(let ([s (symbol->string base)])
|
||||||
(let ([s (symbol->string base)])
|
(if (and ((string-length s) . > . 0)
|
||||||
(if (and ((string-length s) . > . 0)
|
(char=? #\, (string-ref s 0)))
|
||||||
(char=? #\, (string-ref s 0)))
|
(substring s 1 (string-length s))
|
||||||
(substring s 1 (string-length s))
|
relto))]
|
||||||
relto))]
|
[relto (if (procedure? relto) (relto) relto)]
|
||||||
[relto (if (procedure? relto)
|
[else #f]))
|
||||||
(relto)
|
|
||||||
relto)]
|
|
||||||
[else #f]))
|
|
||||||
|
|
||||||
(define re:path-only #rx#"^(.*)/[^/]*$")
|
(define (collapse-module-path s relto-mp)
|
||||||
|
;; relto-mp should be a relative path, '(lib relative-path collection),
|
||||||
|
;; or '(file path) or a thunk that produces one of those
|
||||||
|
|
||||||
(define collapse-module-path
|
;; Used for 'lib paths, so it's always Unix-style
|
||||||
;; relto-mp should be a relative path, '(lib relative-path collection), or '(file path)
|
(define (attach-to-relative-path-string elements relto)
|
||||||
;; or a thunk that produces one of those
|
(let ([elem-str
|
||||||
(lambda (s relto-mp)
|
(substring
|
||||||
;; Used for 'lib paths, so it's always Unix-style
|
(apply string-append
|
||||||
(define (attach-to-relative-path-string elements relto)
|
(map (lambda (i)
|
||||||
(let ([elem-str (substring
|
(string-append
|
||||||
(apply string-append
|
"/"
|
||||||
(map (lambda (i)
|
(cond [(bytes? i) (bytes->string/locale i)]
|
||||||
(string-append
|
[(path? i) (path->string i)]
|
||||||
"/"
|
[(eq? i 'up) ".."]
|
||||||
(cond
|
[else i])))
|
||||||
[(bytes? i) (bytes->string/locale i)]
|
(filter (lambda (x) (not (eq? x 'same)))
|
||||||
[(path? i) (path->string i)]
|
elements)))
|
||||||
[(eq? i 'up) ".."]
|
1)])
|
||||||
[else i])))
|
(if (or (regexp-match #rx"^[.]/+[^/]*" relto)
|
||||||
(filter (lambda (x)
|
(not (regexp-match #rx"/" relto)))
|
||||||
(not (eq? x 'same)))
|
elem-str
|
||||||
elements)))
|
(let ([m (regexp-match #rx"^(.*/)/*[^/]*$" relto)])
|
||||||
1)])
|
(string-append (cadr m) elem-str)))))
|
||||||
(if (or (regexp-match #rx"^[.]/+[^/]*" relto)
|
|
||||||
(not (regexp-match #rx"/" relto)))
|
|
||||||
elem-str
|
|
||||||
(let ([m (regexp-match #rx"^(.*/)/*[^/]*$" relto)])
|
|
||||||
(string-append (cadr m) elem-str)))))
|
|
||||||
|
|
||||||
(define (combine-relative-elements elements)
|
|
||||||
|
|
||||||
;; Used for 'file paths, so it's platform specific:
|
|
||||||
(define (attach-to-relative-path relto)
|
|
||||||
(apply build-path
|
|
||||||
(let-values ([(base n d?) (split-path relto)])
|
|
||||||
(if (eq? base 'relative)
|
|
||||||
'same
|
|
||||||
base))
|
|
||||||
(map (lambda (i)
|
|
||||||
(cond
|
|
||||||
[(bytes? i) (bytes->path i)]
|
|
||||||
[else i]))
|
|
||||||
elements)))
|
|
||||||
|
|
||||||
(when (procedure? relto-mp)
|
|
||||||
(set! relto-mp (relto-mp)))
|
|
||||||
(cond
|
|
||||||
[(or (path? relto-mp)
|
|
||||||
(and (string? relto-mp)
|
|
||||||
(ormap path? elements)))
|
|
||||||
(apply build-path
|
|
||||||
(let-values ([(base name dir?) (split-path relto-mp)])
|
|
||||||
(if (eq? base 'relative)
|
|
||||||
'same
|
|
||||||
base))
|
|
||||||
(map (lambda (x) (if (bytes? x) (bytes->path x) x))
|
|
||||||
elements))]
|
|
||||||
[(string? relto-mp)
|
|
||||||
(bytes->string/locale
|
|
||||||
(apply
|
|
||||||
bytes-append
|
|
||||||
(let ([m (regexp-match re:path-only (string->bytes/locale relto-mp))])
|
|
||||||
(if m
|
|
||||||
(cadr m)
|
|
||||||
#"."))
|
|
||||||
(map (lambda (e)
|
|
||||||
(cond
|
|
||||||
[(eq? e 'same) #"/."]
|
|
||||||
[(eq? e 'up) #"/.."]
|
|
||||||
[else (bytes-append #"/" (if (path? e)
|
|
||||||
(path->bytes e)
|
|
||||||
e))]))
|
|
||||||
elements)))]
|
|
||||||
[(eq? (car relto-mp) 'file)
|
|
||||||
(let ([path ((if (ormap path? elements)
|
|
||||||
values
|
|
||||||
path->string)
|
|
||||||
(attach-to-relative-path (cadr relto-mp)))])
|
|
||||||
(if (path? path)
|
|
||||||
path
|
|
||||||
`(file ,path)))]
|
|
||||||
[(eq? (car relto-mp) 'lib)
|
|
||||||
(let ([path (attach-to-relative-path-string elements
|
|
||||||
(cadr relto-mp))])
|
|
||||||
`(lib ,path ,(caddr relto-mp)))]
|
|
||||||
[(eq? (car relto-mp) 'planet)
|
|
||||||
(let ([pathstr (attach-to-relative-path-string elements
|
|
||||||
(cadr relto-mp))])
|
|
||||||
`(planet ,pathstr ,(caddr relto-mp)))]
|
|
||||||
[else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)]))
|
|
||||||
|
|
||||||
|
(define (combine-relative-elements elements)
|
||||||
|
|
||||||
|
;; Used for 'file paths, so it's platform specific:
|
||||||
|
(define (attach-to-relative-path relto)
|
||||||
|
(apply build-path
|
||||||
|
(let-values ([(base n d?) (split-path relto)])
|
||||||
|
(if (eq? base 'relative) 'same base))
|
||||||
|
(map (lambda (i) (if (bytes? i) (bytes->path i) i))
|
||||||
|
elements)))
|
||||||
|
|
||||||
|
(when (procedure? relto-mp) (set! relto-mp (relto-mp)))
|
||||||
(cond
|
(cond
|
||||||
[(string? s)
|
[(or (path? relto-mp) (and (string? relto-mp) (ormap path? elements)))
|
||||||
;; Parse Unix-style relative path string
|
(apply build-path
|
||||||
(let loop ([elements null][s (string->bytes/utf-8 s)])
|
(let-values ([(base name dir?) (split-path relto-mp)])
|
||||||
(let ([prefix (regexp-match re:dir s)])
|
(if (eq? base 'relative) 'same base))
|
||||||
(if prefix
|
(map (lambda (x) (if (bytes? x) (bytes->path x) x))
|
||||||
(loop (cons (let ([p (cadr prefix)])
|
elements))]
|
||||||
(cond
|
[(string? relto-mp)
|
||||||
[(bytes=? p #".") 'same]
|
(bytes->string/locale
|
||||||
[(bytes=? p #"..") 'up]
|
(apply
|
||||||
[else (bytes->path p)]))
|
bytes-append
|
||||||
elements)
|
(cond [(regexp-match #rx#"^(.*)/[^/]*$"
|
||||||
(caddr prefix))
|
(string->bytes/locale relto-mp))
|
||||||
(combine-relative-elements
|
=> cadr]
|
||||||
(reverse (cons s elements))))))]
|
[else #"."])
|
||||||
[(and (or (not (pair? s))
|
(map (lambda (e)
|
||||||
(not (list? s)))
|
(cond [(eq? e 'same) #"/."]
|
||||||
(not (path? s)))
|
[(eq? e 'up) #"/.."]
|
||||||
#f]
|
[else (bytes-append
|
||||||
[(or (path? s)
|
#"/" (if (path? e) (path->bytes e) e))]))
|
||||||
(eq? (car s) 'file))
|
elements)))]
|
||||||
(let ([p (if (path? s)
|
[(eq? (car relto-mp) 'file)
|
||||||
s
|
(let ([path ((if (ormap path? elements) values path->string)
|
||||||
(cadr s))])
|
(attach-to-relative-path (cadr relto-mp)))])
|
||||||
(if (absolute-path? p)
|
(if (path? path) path `(file ,path)))]
|
||||||
s
|
[(eq? (car relto-mp) 'lib)
|
||||||
(let loop ([p p][elements null])
|
(let ([path (attach-to-relative-path-string
|
||||||
(let-values ([(base name dir?) (split-path p)])
|
elements (cadr relto-mp))])
|
||||||
(cond
|
`(lib ,path ,(caddr relto-mp)))]
|
||||||
[(eq? base 'relative)
|
[(eq? (car relto-mp) 'planet)
|
||||||
(combine-relative-elements
|
(let ([pathstr (attach-to-relative-path-string
|
||||||
(cons name elements))]
|
elements (cadr relto-mp))])
|
||||||
[else (loop base (cons name elements))])))))]
|
`(planet ,pathstr ,(caddr relto-mp)))]
|
||||||
[(eq? (car s) 'lib)
|
[else (error 'combine-relative-elements
|
||||||
(let ([cols (let ([len (length s)])
|
"don't know how to deal with: ~s" relto-mp)]))
|
||||||
(if (= len 2)
|
|
||||||
(list "mzlib")
|
(cond [(string? s)
|
||||||
(cddr s)))])
|
;; Parse Unix-style relative path string
|
||||||
`(lib ,(attach-to-relative-path-string
|
(combine-relative-elements (explode-relpath-string s))]
|
||||||
(append (cdr cols)
|
[(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
|
||||||
(list (cadr s)))
|
#f]
|
||||||
".")
|
[(or (path? s) (eq? (car s) 'file))
|
||||||
,(car cols)))]
|
(let ([p (if (path? s) s (cadr s))])
|
||||||
[(eq? (car s) 'planet)
|
(if (absolute-path? p)
|
||||||
(let ((cols (cdddr s)))
|
s
|
||||||
`(planet
|
(let loop ([p p] [elements null])
|
||||||
,(attach-to-relative-path-string
|
(let-values ([(base name dir?) (split-path p)])
|
||||||
(append cols
|
(cond [(eq? base 'relative)
|
||||||
(list (cadr s)))
|
(combine-relative-elements (cons name elements))]
|
||||||
".")
|
[else (loop base (cons name elements))])))))]
|
||||||
,(caddr s)))]
|
[(eq? (car s) 'lib)
|
||||||
[else #f])))
|
(let ([cols (let ([len (length s)])
|
||||||
|
(if (= len 2) (list "mzlib") (cddr s)))])
|
||||||
|
`(lib ,(attach-to-relative-path-string
|
||||||
|
(append (cdr cols) (list (cadr s)))
|
||||||
|
".")
|
||||||
|
,(car cols)))]
|
||||||
|
[(eq? (car s) 'planet)
|
||||||
|
(let ([cols (cdddr s)])
|
||||||
|
`(planet
|
||||||
|
,(attach-to-relative-path-string
|
||||||
|
(append cols (list (cadr s)))
|
||||||
|
".")
|
||||||
|
,(caddr s)))]
|
||||||
|
[else #f]))
|
||||||
|
|
||||||
(define (collapse-module-path-index mpi relto-mp)
|
(define (collapse-module-path-index mpi relto-mp)
|
||||||
(let-values ([(path base) (module-path-index-split mpi)])
|
(let-values ([(path base) (module-path-index-split mpi)])
|
||||||
(if path
|
(if path
|
||||||
(collapse-module-path path
|
(collapse-module-path
|
||||||
(cond
|
path
|
||||||
[(symbol? base)
|
(cond
|
||||||
(let ([s (symbol->string base)])
|
[(symbol? base)
|
||||||
(if (and ((string-length s) . > . 0)
|
(let ([s (symbol->string base)])
|
||||||
(char=? #\, (string-ref s 0)))
|
(if (and ((string-length s) . > . 0)
|
||||||
`(file ,(substring s 1 (string-length s)))
|
(char=? #\, (string-ref s 0)))
|
||||||
relto-mp))]
|
`(file ,(substring s 1))
|
||||||
[(module-path-index? base)
|
relto-mp))]
|
||||||
(collapse-module-path-index base relto-mp)]
|
[(module-path-index? base)
|
||||||
[else relto-mp]))
|
(collapse-module-path-index base relto-mp)]
|
||||||
relto-mp)))
|
[else relto-mp]))
|
||||||
|
relto-mp)))
|
||||||
|
|
||||||
(define (show-import-tree module-path)
|
(define (show-import-tree module-path)
|
||||||
(let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""])
|
(let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""])
|
||||||
(printf "~a~a~a~n" indent path fs)
|
(printf "~a~a~a\n" indent path fs)
|
||||||
(let ([code (get-module-code path)])
|
(let ([code (get-module-code path)])
|
||||||
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)]
|
(let-values ([(imports fs-imports ft-imports)
|
||||||
[(mk-loop) (lambda (fs)
|
(module-compiled-imports code)])
|
||||||
(lambda (i)
|
(define ((mk-loop fs) i)
|
||||||
(unless (symbol? i)
|
(unless (symbol? i)
|
||||||
(loop (resolve-module-path-index i path)
|
(loop (resolve-module-path-index i path)
|
||||||
(format " ~a" indent)
|
(format " ~a" indent)
|
||||||
fs))))])
|
fs)))
|
||||||
(for-each (mk-loop "") imports)
|
(for-each (mk-loop "") imports)
|
||||||
(for-each (mk-loop " [for-syntax]") fs-imports)
|
(for-each (mk-loop " [for-syntax]") fs-imports)
|
||||||
(for-each (mk-loop " [for-template]") ft-imports)))))
|
(for-each (mk-loop " [for-template]") ft-imports)))))
|
||||||
|
|
||||||
(define (module-path-v-string? v)
|
(define (module-path-v-string? v)
|
||||||
(and (regexp-match #rx"^[-a-zA-Z0-9./]+$" v)
|
(and (regexp-match #rx"^[-a-zA-Z0-9./]+$" v)
|
||||||
(not (regexp-match #rx"^/" v))
|
(not (regexp-match #rx"^/" v))
|
||||||
(not (regexp-match #rx"/$" v))))
|
(not (regexp-match #rx"/$" v))))
|
||||||
|
|
||||||
(define (module-path-v? v)
|
(define (module-path-v? v)
|
||||||
(cond
|
(cond [(path? v) #t]
|
||||||
[(path? v) #t]
|
[(string? v) (module-path-v-string? v)]
|
||||||
[(string? v)
|
[(pair? v)
|
||||||
(module-path-v-string? v)]
|
(case (car v)
|
||||||
[(pair? v)
|
[(file) (and (pair? (cdr v))
|
||||||
(case (car v)
|
(path-string? (cadr v))
|
||||||
[(file) (and (pair? (cdr v))
|
(null? (cddr v)))]
|
||||||
(path-string? (cadr v))
|
[(lib) (and (pair? (cdr v))
|
||||||
(null? (cddr v)))]
|
(list? (cdr v))
|
||||||
[(lib) (and (pair? (cdr v))
|
(map module-path-v-string? (cdr v)))]
|
||||||
(list? (cdr v))
|
[(planet) #t]
|
||||||
(map module-path-v-string? (cdr v)))]
|
[else #f])]
|
||||||
[(planet) #t]
|
[else #f]))
|
||||||
[else #f])]
|
|
||||||
[else #f]))
|
|
||||||
|
|
||||||
(define rel-to-path-string/thunk/#f
|
(define rel-to-path-string/thunk/#f
|
||||||
(or/c path-string?
|
(or/c path-string? (-> path-string?) false/c))
|
||||||
(-> path-string?)
|
|
||||||
false/c))
|
|
||||||
|
|
||||||
(define simple-rel-to-module-path-v/c
|
(define simple-rel-to-module-path-v/c
|
||||||
(or/c
|
(or/c
|
||||||
(list/c (symbols 'lib) module-path-v-string? module-path-v-string?)
|
(list/c (symbols 'lib) module-path-v-string? module-path-v-string?)
|
||||||
(list/c (symbols 'file) (and/c string? path-string?))
|
(list/c (symbols 'file) (and/c string? path-string?))
|
||||||
;; not quite specific enough of a contract -- it should also spell out what's
|
;; not quite specific enough of a contract -- it should also spell out
|
||||||
;; allowed in the package spec
|
;; what's allowed in the package spec
|
||||||
(cons/c (symbols 'planet) (cons/c string? (cons/c (listof any/c) (listof string?))))
|
(cons/c (symbols 'planet)
|
||||||
|
(cons/c string? (cons/c (listof any/c) (listof string?))))
|
||||||
path-string?))
|
path-string?))
|
||||||
|
|
||||||
(define rel-to-module-path-v/c
|
(define rel-to-module-path-v/c
|
||||||
(or/c simple-rel-to-module-path-v/c
|
(or/c simple-rel-to-module-path-v/c (-> simple-rel-to-module-path-v/c)))
|
||||||
(-> simple-rel-to-module-path-v/c)))
|
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[check-module-form (syntax? symbol? (or/c string? path? false/c)
|
[check-module-form (syntax? symbol? (or/c string? path? false/c) . -> . any)]
|
||||||
. -> . any)]
|
|
||||||
|
|
||||||
[get-module-code ([path-string?]
|
[get-module-code ([path-string?]
|
||||||
[(and/c path-string?
|
[(and/c path-string? relative-path?)
|
||||||
relative-path?)
|
(any/c . -> . any)
|
||||||
(any/c . -> . any)
|
(or/c false/c (path? boolean? . -> . any))]
|
||||||
(or/c false/c
|
. opt-> .
|
||||||
(path? boolean? . -> . any))]
|
any)])
|
||||||
. opt-> .
|
|
||||||
any)])
|
(provide exn:get-module-code
|
||||||
|
exn:get-module-code?
|
||||||
|
exn:get-module-code-path
|
||||||
|
make-exn:get-module-code)
|
||||||
|
|
||||||
(provide
|
|
||||||
exn:get-module-code
|
|
||||||
exn:get-module-code?
|
|
||||||
exn:get-module-code-path
|
|
||||||
make-exn:get-module-code)
|
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[resolve-module-path (module-path-v?
|
[resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
|
||||||
rel-to-path-string/thunk/#f
|
. -> . path?)]
|
||||||
. -> . path?)]
|
[resolve-module-path-index ((or/c symbol? module-path-index?)
|
||||||
[resolve-module-path-index ((or/c symbol?
|
rel-to-path-string/thunk/#f
|
||||||
module-path-index?)
|
. -> . path?)]
|
||||||
rel-to-path-string/thunk/#f
|
|
||||||
. -> . path?)]
|
[collapse-module-path (module-path-v? rel-to-module-path-v/c
|
||||||
|
. -> . simple-rel-to-module-path-v/c)]
|
||||||
|
[collapse-module-path-index ((or/c symbol? module-path-index?)
|
||||||
|
rel-to-module-path-v/c
|
||||||
|
. -> . simple-rel-to-module-path-v/c)])
|
||||||
|
|
||||||
[collapse-module-path (module-path-v?
|
|
||||||
rel-to-module-path-v/c
|
|
||||||
. -> .
|
|
||||||
simple-rel-to-module-path-v/c)]
|
|
||||||
[collapse-module-path-index ((or/c symbol?
|
|
||||||
module-path-index?)
|
|
||||||
rel-to-module-path-v/c
|
|
||||||
. -> . simple-rel-to-module-path-v/c)])
|
|
||||||
|
|
||||||
(provide show-import-tree))
|
(provide show-import-tree))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user