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

split moddep into smaller libraries

Browse Source 
svn: r5966
This commit is contained in:
Matthew Flatt 2007-04-17 13:52:13 +00:00
parent e885e79295
commit 382209d3fb
8 changed files with 501 additions and 431 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/serialize.ss
View File

@ -1,6 +1,6 @@
(module serialize mzscheme
(require-for-syntax (lib "struct.ss" "syntax"))
(require (lib "moddep.ss" "syntax")
(require (lib "modcollapse.ss" "syntax")
(lib "etc.ss")
(lib "list.ss")
"private/serialize-structs.ss")

52
collects/syntax/doc.txt
View File

@ -289,10 +289,15 @@ _docprovide.ss_: attaching documentation to exports
_moddep.ss_: inspecting modules and module dependencies
======================================================================
Interpretations of module paths in this library mimic that of the
default module path resolver in MzScheme (which means that the library
is limited, but certainly useful as no other module path resolvers
currently exist).
Re-exports "modread.ss", "modcode.ss", "modcollapse.ss", and
"modresolve.ss", in addition to the following:
> (show-import-tree module-path-v) - a debugging aid that prints the
import hierarchy starting from a given module path.
======================================================================
_modread.ss_: reading module source code
======================================================================
> (with-module-reading-parameterization thunk) - calls `thunk' with
all reader parameters reset to their default values.
@ -317,6 +322,10 @@ currently exist).
If stx is eof or eof wrapped as a syntax object, then an error is
raised or #f is returned.
======================================================================
_modcode.ss_: getting module compiled code
======================================================================
> (get-module-code path [compiled-subdir compile-proc ext-proc]) -
returns a compiled expression for the declaration of the module
specified by `module-path-v'. The `module-path-v' argument is a
@ -346,6 +355,29 @@ currently exist).
raised (to report that an extension file cannot be used) when
`ext-proc' is #f.
> moddep-current-open-input-file
A parameter whose value is used like `open-input-file' to read a
module source or ".zo" file.
> exn:get-module-code
> exn:get-module-code?
> exn:get-module-code-path
> make-exn:get-module-code
An exception structure type for exceptions raised by
`get-module-code'.
======================================================================
_modresolve.ss_: resolving module paths to file paths
======================================================================
Interpretations of module paths in this library mimic that of the
default module path resolver in MzScheme (which means that the library
is limited, but certainly useful as no other module path resolvers
currently exist).
> (resolve-module-path module-path-v rel-to-path-string/thunk/#f) -
resolves a module path to filename path. The module path is resolved
relative to `rel-to-path-string/thunk/#f' if it is a path string
@ -362,6 +394,15 @@ currently exist).
the "self" module path index, then an exception is raised unless
`rel-to-path-string/thunk/#f' is a path string.
======================================================================
_modcollapse.ss_: simplifying module paths
======================================================================
Interpretations of module paths in this library mimic that of the
default module path resolver in MzScheme (which means that the library
is limited, but certainly useful as no other module path resolvers
currently exist).
> (collapse-module-path module-path-v rel-to-module-path-v) - returns
a "simplified" module path by combining `module-path-v' with
`rel-to-module-path', where the latter must have the form '(lib
@ -381,9 +422,6 @@ currently exist).
`rel-to-module-path-v' base is used where the module path index
contains the "self" index.
> (show-import-tree module-path-v) - a debugging aid that prints the
import hierarchy starting from a given module path.
======================================================================
_readerr.ss_: signaling parse errors
======================================================================

125
collects/syntax/modcode.ss Normal file
View File

@ -0,0 +1,125 @@
(module modcode mzscheme
(require (lib "port.ss")
(lib "kw.ss")
(lib "contract.ss")
"modread.ss")
(provide moddep-current-open-input-file
exn:get-module-code
exn:get-module-code?
exn:get-module-code-path
make-exn:get-module-code)
(provide/contract
[get-module-code ([path-string?]
[(and/c path-string? relative-path?)
(any/c . -> . any)
(or/c false/c (path? boolean? . -> . any))]
. opt-> .
any)])
(define moddep-current-open-input-file
(make-parameter open-input-file))
(define (resolve s)
(if (complete-path? s)
s
(let ([d (current-load-relative-directory)])
(if d (path->complete-path s d) s))))
(define (date>=? a bm)
(and a (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(file-or-directory-modify-seconds a))])
(or (and (not bm) am) (and am bm (>= am bm))))))
(define (read-one path src?)
(let ([p ((moddep-current-open-input-file) path)])
(when src? (port-count-lines! p) (strip-shell-command-start p))
(dynamic-wind
void
(lambda ()
(let ([v (with-module-reading-parameterization
(lambda () (read-syntax path p)))])
(when (eof-object? v)
(error 'read-one
"empty file; expected a module declaration in: ~a" path))
(let* ([name (let-values ([(base name dir?) (split-path path)])
(string->symbol
(bytes->string/utf-8
(path->bytes (path-replace-suffix name #""))
#\?)))]
[v (check-module-form v name path)])
(unless (eof-object? (read p))
(error 'read-one
"file has more than one expression; expected a module declaration only in: ~a"
path))
(if (and (syntax? v) (compiled-expression? (syntax-e v)))
(syntax-e v)
v))))
(lambda () (close-input-port p)))))
(define-struct (exn:get-module-code exn) (path))
(define/kw (get-module-code path
#:optional
[sub-path "compiled"] [compiler compile] [extension-handler #f])
(unless (path-string? path)
(raise-type-error 'get-module-code "path or string (sans nul)" path))
(let*-values ([(path) (resolve path)]
[(base file dir?) (split-path path)]
[(base) (if (eq? base 'relative) 'same base)]
[(mode) (use-compiled-file-paths)])
(let* ([get-so (lambda (file)
(build-path
base sub-path "native"
(system-library-subpath)
(path-replace-suffix file (system-type 'so-suffix))))]
[zo (build-path base sub-path (path-replace-suffix file #".zo"))]
[so (get-so file)]
[_loader-so (get-so (string->path "_loader.ss"))]
[path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(file-or-directory-modify-seconds path))]
[with-dir (lambda (t)
(parameterize ([current-load-relative-directory
(if (path? base)
base
(current-directory))])
(t)))])
(cond
;; Use .zo, if it's new enough
[(date>=? zo path-d) (read-one zo #f)]
;; Otherwise, use source if it exists
[path-d (with-dir (lambda () (compiler (read-one path #t))))]
;; No source --- maybe there's an .so?
[(and (not path-d) (date>=? so path-d))
(if extension-handler
(extension-handler so #f)
(raise (make-exn:get-module-code
(format "get-module-code: cannot use extension file; ~e" so)
(current-continuation-marks)
so)))]
;; Or maybe even a _loader.so?
[(and (not path-d)
(date>=? _loader-so path-d)
(let ([getter (load-extension _loader-so)])
(let-values ([(loader modname)
(getter (string->symbol
(bytes->string/latin-1
(path->bytes
(path-replace-suffix file #"")))))])
loader)))
=> (lambda (loader)
(if extension-handler
(extension-handler loader #t)
(raise (make-exn:get-module-code
(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))])))))

144
collects/syntax/modcollapse.ss Normal file
View File

@ -0,0 +1,144 @@
(module modcollapse mzscheme
(require (lib "list.ss")
(lib "contract.ss")
"private/modhelp.ss")
(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
;; Used for 'lib paths, so it's always Unix-style
(define (attach-to-relative-path-string elements relto)
(let ([elem-str
(substring
(apply string-append
(map (lambda (i)
(string-append
"/"
(cond [(bytes? i) (bytes->string/locale i)]
[(path? i) (path->string i)]
[(eq? i 'up) ".."]
[else i])))
(filter (lambda (x) (not (eq? x 'same)))
elements)))
1)])
(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) (if (bytes? i) (bytes->path i) 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
(cond [(regexp-match #rx#"^(.*)/[^/]*$"
(string->bytes/locale relto-mp))
=> cadr]
[else #"."])
(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)]))
(cond [(string? s)
;; Parse Unix-style relative path string
(combine-relative-elements (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))])
(if (absolute-path? p)
s
(let loop ([p p] [elements null])
(let-values ([(base name dir?) (split-path p)])
(cond [(eq? base 'relative)
(combine-relative-elements (cons name elements))]
[else (loop base (cons name elements))])))))]
[(eq? (car s) 'lib)
(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)
(let-values ([(path base) (module-path-index-split mpi)])
(if path
(collapse-module-path
path
(cond
[(symbol? base)
(let ([s (symbol->string base)])
(if (and ((string-length s) . > . 0)
(char=? #\, (string-ref s 0)))
`(file ,(substring s 1))
relto-mp))]
[(module-path-index? base)
(collapse-module-path-index base relto-mp)]
[else relto-mp]))
relto-mp)))
(define simple-rel-to-module-path-v/c
(or/c
(list/c (symbols 'lib) module-path-v-string? module-path-v-string?)
(list/c (symbols 'file) (and/c string? path-string?))
;; not quite specific enough of a contract -- it should also spell out
;; what's allowed in the package spec
(cons/c (symbols 'planet)
(cons/c string? (cons/c (listof any/c) (listof string?))))
path-string?))
(define rel-to-module-path-v/c
(or/c simple-rel-to-module-path-v/c (-> simple-rel-to-module-path-v/c)))
(provide/contract
[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)]))

433
collects/syntax/moddep.ss
View File

@ -1,363 +1,15 @@
(module moddep mzscheme
(require (lib "port.ss")
(lib "list.ss")
(lib "string.ss")
(lib "contract.ss")
(lib "kw.ss")
(lib "resolver.ss" "planet"))
(require "modread.ss"
"modcode.ss"
"modcollapse.ss"
"modresolve.ss")
(provide moddep-current-open-input-file)
(define moddep-current-open-input-file
(make-parameter open-input-file))
(provide with-module-reading-parameterization)
(define (with-module-reading-parameterization thunk)
(parameterize ([read-case-sensitive #t]
[read-square-bracket-as-paren #t]
[read-curly-brace-as-paren #t]
[read-accept-box #t]
[read-accept-compiled #t]
[read-accept-bar-quote #t]
[read-accept-graph #t]
[read-decimal-as-inexact #t]
[read-accept-dot #t]
[read-accept-quasiquote #t]
[read-accept-reader #t]
[current-readtable #f])
(thunk)))
(define (raise-wrong-module-name filename expected-name name)
(error 'load-handler
"expected a `module' declaration for `~a' in ~s, found: ~a"
expected-name filename name))
(define (check-module-form exp expected-module filename)
(cond [(or (eof-object? exp) (eof-object? (syntax-e exp)))
(and filename
(error 'load-handler
"expected a `module' declaration for `~a' in ~s, but found end-of-file"
expected-module filename))]
[(compiled-module-expression? (syntax-e exp))
(if (eq? (module-compiled-name (syntax-e exp)) expected-module)
;; It's fine:
exp
;; Wrong name:
(and filename (raise-wrong-module-name
filename expected-module
(module-compiled-name (syntax-e exp)))))]
[(and (syntax? exp)
(syntax-case exp ()
[(mod nm . _)
(and (eq? (syntax-e #'mod) 'module) (identifier? #'nm))]
[_else #f]))
;; It's ok; need to install a specific `module' binding:
(with-syntax ([(mod nm . _) exp])
(unless (eq? (syntax-e #'nm) expected-module)
(raise-wrong-module-name filename expected-module
(syntax-e #'nm)))
(datum->syntax-object exp
(cons #'module (cdr (syntax-e exp)))
exp
exp))]
[else
(and filename
(error 'load-handler
"expected a `module' declaration for `~a' in ~s, but found something else"
expected-module filename))]))
(define (resolve s)
(if (complete-path? s)
s
(let ([d (current-load-relative-directory)])
(if d (path->complete-path s d) s))))
(define (date>=? a bm)
(and a (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(file-or-directory-modify-seconds a))])
(or (and (not bm) am) (and am bm (>= am bm))))))
(define (read-one path src?)
(let ([p ((moddep-current-open-input-file) path)])
(when src? (port-count-lines! p) (strip-shell-command-start p))
(dynamic-wind
void
(lambda ()
(let ([v (with-module-reading-parameterization
(lambda () (read-syntax path p)))])
(when (eof-object? v)
(error 'read-one
"empty file; expected a module declaration in: ~a" path))
(let* ([name (let-values ([(base name dir?) (split-path path)])
(string->symbol
(bytes->string/utf-8
(path->bytes (path-replace-suffix name #""))
#\?)))]
[v (check-module-form v name path)])
(unless (eof-object? (read p))
(error 'read-one
"file has more than one expression; expected a module declaration only in: ~a"
path))
(if (and (syntax? v) (compiled-expression? (syntax-e v)))
(syntax-e v)
v))))
(lambda () (close-input-port p)))))
(define-struct (exn:get-module-code exn) (path))
(define/kw (get-module-code path
#:optional
[sub-path "compiled"] [compiler compile] [extension-handler #f])
(unless (path-string? path)
(raise-type-error 'get-module-code "path or string (sans nul)" path))
(let*-values ([(path) (resolve path)]
[(base file dir?) (split-path path)]
[(base) (if (eq? base 'relative) 'same base)]
[(mode) (use-compiled-file-paths)])
(let* ([get-so (lambda (file)
(build-path
base sub-path "native"
(system-library-subpath)
(path-replace-suffix file (system-type 'so-suffix))))]
[zo (build-path base sub-path (path-replace-suffix file #".zo"))]
[so (get-so file)]
[_loader-so (get-so (string->path "_loader.ss"))]
[path-d (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(file-or-directory-modify-seconds path))]
[with-dir (lambda (t)
(parameterize ([current-load-relative-directory
(if (path? base)
base
(current-directory))])
(t)))])
(cond
;; Use .zo, if it's new enough
[(date>=? zo path-d) (read-one zo #f)]
;; Otherwise, use source if it exists
[path-d (with-dir (lambda () (compiler (read-one path #t))))]
;; No source --- maybe there's an .so?
[(and (not path-d) (date>=? so path-d))
(if extension-handler
(extension-handler so #f)
(raise (make-exn:get-module-code
(format "get-module-code: cannot use extension file; ~e" so)
(current-continuation-marks)
so)))]
;; Or maybe even a _loader.so?
[(and (not path-d)
(date>=? _loader-so path-d)
(let ([getter (load-extension _loader-so)])
(let-values ([(loader modname)
(getter (string->symbol
(bytes->string/latin-1
(path->bytes
(path-replace-suffix file #"")))))])
loader)))
=> (lambda (loader)
(if extension-handler
(extension-handler loader #t)
(raise (make-exn:get-module-code
(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 (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))
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)]))
(define (explode-relpath-string p)
(map (lambda (p)
(cond [(assoc p '((#"." . same) (#".." . up))) => cdr]
[else (bytes->path p)]))
(regexp-split #rx#"/+" (string->bytes/utf-8 p))))
(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 [(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))))))]
[(eq? (car s) 'lib)
(let* ([cols (let ([len (length s)])
(if (= len 2) (list "mzlib") (cddr s)))]
[p (apply collection-path cols)])
(build-path p (cadr s)))]
[(eq? (car s) 'planet)
(let ([module-id
(and (path? relto)
(string->symbol
(string-append
"," (path->string (path->complete-path relto)))))])
(let-values ([(path pkg)
(get-planet-module-path/pkg s module-id #f)])
path))]
[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
(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)]
[(symbol? base)
(let ([s (symbol->string base)])
(if (and ((string-length s) . > . 0)
(char=? #\, (string-ref s 0)))
(substring s 1 (string-length s))
relto))]
[relto (if (procedure? relto) (relto) relto)]
[else #f]))
(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
;; Used for 'lib paths, so it's always Unix-style
(define (attach-to-relative-path-string elements relto)
(let ([elem-str
(substring
(apply string-append
(map (lambda (i)
(string-append
"/"
(cond [(bytes? i) (bytes->string/locale i)]
[(path? i) (path->string i)]
[(eq? i 'up) ".."]
[else i])))
(filter (lambda (x) (not (eq? x 'same)))
elements)))
1)])
(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) (if (bytes? i) (bytes->path i) 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
(cond [(regexp-match #rx#"^(.*)/[^/]*$"
(string->bytes/locale relto-mp))
=> cadr]
[else #"."])
(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)]))
(cond [(string? s)
;; Parse Unix-style relative path string
(combine-relative-elements (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))])
(if (absolute-path? p)
s
(let loop ([p p] [elements null])
(let-values ([(base name dir?) (split-path p)])
(cond [(eq? base 'relative)
(combine-relative-elements (cons name elements))]
[else (loop base (cons name elements))])))))]
[(eq? (car s) 'lib)
(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)
(let-values ([(path base) (module-path-index-split mpi)])
(if path
(collapse-module-path
path
(cond
[(symbol? base)
(let ([s (symbol->string base)])
(if (and ((string-length s) . > . 0)
(char=? #\, (string-ref s 0)))
`(file ,(substring s 1))
relto-mp))]
[(module-path-index? base)
(collapse-module-path-index base relto-mp)]
[else relto-mp]))
relto-mp)))
(provide (all-from "modread.ss")
(all-from "modcode.ss")
(all-from "modcollapse.ss")
(all-from "modresolve.ss")
show-import-tree)
(define (show-import-tree module-path)
(let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""])
@ -372,70 +24,5 @@
fs)))
(for-each (mk-loop "") 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)
(and (regexp-match? #rx"^[-a-zA-Z0-9./]+$" v)
(not (regexp-match? #rx"^/" v))
(not (regexp-match? #rx"/$" v))))
(define (module-path-v? v)
(cond [(path? v) #t]
[(string? v) (module-path-v-string? v)]
[(pair? v)
(case (car v)
[(file) (and (pair? (cdr v))
(path-string? (cadr v))
(null? (cddr v)))]
[(lib) (and (pair? (cdr v))
(list? (cdr v))
(andmap module-path-v-string? (cdr v)))]
[(planet) #t]
[else #f])]
[else #f]))
(define rel-to-path-string/thunk/#f
(or/c path-string? (-> path-string?) false/c))
(define simple-rel-to-module-path-v/c
(or/c
(list/c (symbols 'lib) module-path-v-string? module-path-v-string?)
(list/c (symbols 'file) (and/c string? path-string?))
;; not quite specific enough of a contract -- it should also spell out
;; what's allowed in the package spec
(cons/c (symbols 'planet)
(cons/c string? (cons/c (listof any/c) (listof string?))))
path-string?))
(define rel-to-module-path-v/c
(or/c simple-rel-to-module-path-v/c (-> simple-rel-to-module-path-v/c)))
(provide/contract
[check-module-form ((or/c syntax? eof-object?) symbol? (or/c string? path? false/c) . -> . any)]
[get-module-code ([path-string?]
[(and/c path-string? relative-path?)
(any/c . -> . any)
(or/c false/c (path? boolean? . -> . any))]
. opt-> .
any)])
(provide exn:get-module-code
exn:get-module-code?
exn:get-module-code-path
make-exn:get-module-code)
(provide/contract
[resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
. -> . path?)]
[resolve-module-path-index ((or/c symbol? module-path-index?)
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)])
(provide show-import-tree))

60
collects/syntax/modread.ss Normal file
View File

@ -0,0 +1,60 @@
(module modread mzscheme
(require (lib "contract.ss"))
(provide with-module-reading-parameterization)
(provide/contract
[check-module-form ((or/c syntax? eof-object?) symbol? (or/c string? path? false/c) . -> . any)])
(define (with-module-reading-parameterization thunk)
(parameterize ([read-case-sensitive #t]
[read-square-bracket-as-paren #t]
[read-curly-brace-as-paren #t]
[read-accept-box #t]
[read-accept-compiled #t]
[read-accept-bar-quote #t]
[read-accept-graph #t]
[read-decimal-as-inexact #t]
[read-accept-dot #t]
[read-accept-quasiquote #t]
[read-accept-reader #t]
[current-readtable #f])
(thunk)))
(define (raise-wrong-module-name filename expected-name name)
(error 'load-handler
"expected a `module' declaration for `~a' in ~s, found: ~a"
expected-name filename name))
(define (check-module-form exp expected-module filename)
(cond [(or (eof-object? exp) (eof-object? (syntax-e exp)))
(and filename
(error 'load-handler
"expected a `module' declaration for `~a' in ~s, but found end-of-file"
expected-module filename))]
[(compiled-module-expression? (syntax-e exp))
(if (eq? (module-compiled-name (syntax-e exp)) expected-module)
;; It's fine:
exp
;; Wrong name:
(and filename (raise-wrong-module-name
filename expected-module
(module-compiled-name (syntax-e exp)))))]
[(and (syntax? exp)
(syntax-case exp ()
[(mod nm . _)
(and (eq? (syntax-e #'mod) 'module) (identifier? #'nm))]
[_else #f]))
;; It's ok; need to install a specific `module' binding:
(with-syntax ([(mod nm . _) exp])
(unless (eq? (syntax-e #'nm) expected-module)
(raise-wrong-module-name filename expected-module
(syntax-e #'nm)))
(datum->syntax-object exp
(cons #'module (cdr (syntax-e exp)))
exp
exp))]
[else
(and filename
(error 'load-handler
"expected a `module' declaration for `~a' in ~s, but found something else"
expected-module filename))])))

83
collects/syntax/modresolve.ss Normal file
View File

@ -0,0 +1,83 @@
(module modresolve mzscheme
(require (lib "list.ss")
(lib "contract.ss")
(lib "resolver.ss" "planet")
"private/modhelp.ss")
(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))
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)]))
(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 [(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))))))]
[(eq? (car s) 'lib)
(let* ([cols (let ([len (length s)])
(if (= len 2) (list "mzlib") (cddr s)))]
[p (apply collection-path cols)])
(build-path p (cadr s)))]
[(eq? (car s) 'planet)
(let ([module-id
(and (path? relto)
(string->symbol
(string-append
"," (path->string (path->complete-path relto)))))])
(let-values ([(path pkg)
(get-planet-module-path/pkg s module-id #f)])
path))]
[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
(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)]
[(symbol? base)
(let ([s (symbol->string base)])
(if (and ((string-length s) . > . 0)
(char=? #\, (string-ref s 0)))
(substring s 1 (string-length s))
relto))]
[relto (if (procedure? relto) (relto) relto)]
[else #f]))
(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
. -> . path?)]
[resolve-module-path-index ((or/c symbol? module-path-index?)
rel-to-path-string/thunk/#f
. -> . path?)]))

33
collects/syntax/private/modhelp.ss Normal file
View File

@ -0,0 +1,33 @@
(module modhelp mzscheme
(require (lib "string.ss"))
(provide explode-relpath-string
module-path-v?
module-path-v-string?)
(define (explode-relpath-string p)
(map (lambda (p)
(cond [(assoc p '((#"." . same) (#".." . up))) => cdr]
[else (bytes->path p)]))
(regexp-split #rx#"/+" (string->bytes/utf-8 p))))
(define (module-path-v-string? v)
(and (regexp-match? #rx"^[-a-zA-Z0-9./]+$" v)
(not (regexp-match? #rx"^/" v))
(not (regexp-match? #rx"/$" v))))
(define (module-path-v? v)
(cond [(path? v) #t]
[(string? v) (module-path-v-string? v)]
[(pair? v)
(case (car v)
[(file) (and (pair? (cdr v))
(path-string? (cadr v))
(null? (cddr v)))]
[(lib) (and (pair? (cdr v))
(list? (cdr v))
(andmap module-path-v-string? (cdr v)))]
[(planet) #t]
[else #f])]
[else #f])))