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

moddep contracts and testing

Browse Source 
svn: r2407
This commit is contained in:
Matthew Flatt 2006-03-10 03:35:23 +00:00
parent 9379eec0e9
commit 17670dd89d
4 changed files with 215 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/private/contract-util.ss
View File

@ -74,7 +74,7 @@
set)
(parameterize ([current-inspector (make-inspector)])
(make-struct-type 'exn:fail:contract2
struct:exn:fail
struct:exn:fail:contract
1
0
#f

18
collects/syntax/doc.txt
View File

@ -338,23 +338,27 @@ 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, to
the directory result of calling the thunk if it is a thunk, or to
the current directory otherwise.
relative to `rel-to-path-string/thunk/#f' if it is a path string
(assumed to be for a file), to the directory result of calling the
thunk if it is a thunk, or to the current directory otherwise. The
`module-path-v' argument is a quoted module path, as for MzScheme's
`dynamic-require' using the default module path resolver.
> (resolve-module-path-index module-path-index rel-to-path-string/thunk/#f)
- like `resolve-module-path' but the input is a module path index
(see the MzScheme manual for details); in this case, the
`rel-to-path-string/thunk/#f' base is used where the module path index
contains the "self" index. If `module-path-v' represents the
"self" module path index, then an exception is raised unless
`rel-to-path-string/thunk/#f' base is used where the module path
index contains the "self" index. If `module-path-index' depends on
the "self" module path index, then an exception is raised unless
`rel-to-path-string/thunk/#f' is a path string.
> (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
<relative-path> <collection>), '(file <string>), a path, or a thunk
to generate one of those.
to generate one of those. The `module-path-v' argument is a quoted
module path, as for MzScheme's `dynamic-require' using the default
module path resolver.
The result can be a path if `module-path-v' contains a path element
that is needed for the result, or if `rel-to-module-path-v' is a

100
collects/syntax/moddep.ss
View File

@ -2,6 +2,7 @@
(module moddep mzscheme
(require (lib "etc.ss")
(lib "port.ss")
(lib "contract.ss")
(lib "resolver.ss" "planet"))
@ -212,7 +213,7 @@
relto)]
[(pair? relto) relto]
[(not dir?)
(error 'resolve-module-path-index "can't resolve \"self\" with just a relative directory ~e" relto)]
(error 'resolve-module-path-index "can't resolve \"self\" with non-path relative-to: ~e" relto)]
[(procedure? relto) (relto)]
[else
(current-directory)]))
@ -321,7 +322,10 @@
(path->bytes e)
e))]))
elements)))]
[else (let ([path (path->string
[else (let ([path ((if (and (ormap path? elements)
(eq? (car relto-mp) 'file))
values
path->string)
(apply build-path
(let-values ([(base n d?) (split-path (cadr relto-mp))])
(if (eq? base 'relative)
@ -332,9 +336,11 @@
[(bytes? i) (bytes->path i)]
[else i]))
elements)))])
(if (eq? (car relto-mp) 'lib)
`(lib ,path ,(caddr relto-mp))
`(file ,path)))]))])
(if (path? path)
path
(if (eq? (car relto-mp) 'lib)
`(lib ,path ,(caddr relto-mp))
`(file ,path))))]))])
(cond
[(string? s)
;; Parse Unix-style relative path string
@ -412,18 +418,78 @@
(for-each (mk-loop " [for-syntax]") fs-imports)
(for-each (mk-loop " [for-template]") ft-imports)))))
(provide check-module-form
(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))))
get-module-code
exn:get-module-code
exn:get-module-code?
exn:get-module-code-path
make-exn:get-module-code
(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))
(map 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?))
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 (syntax? symbol? (or/c string? 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)
resolve-module-path
resolve-module-path-index
(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
collapse-module-path-index
show-import-tree))
[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))

120
collects/tests/mzscheme/moddep.ss Normal file
View File

@ -0,0 +1,120 @@
;; FIXME: this file needs tests for planet paths
(load-relative "loadtest.ss")
(SECTION 'MODDEP)
(require (lib "moddep.ss" "syntax"))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resolve-module-path[-index]
(define (test-rmp expect path rel-to)
(test expect resolve-module-path path rel-to)
(let ([pi-rel-to (if (path? rel-to)
rel-to
(build-path (current-directory) "self"))])
(test expect resolve-module-path-index
(module-path-index-join path (module-path-index-join #f #f))
pi-rel-to)
(test expect resolve-module-path-index
(module-path-index-join path
(module-path-index-join
"other.ss"
(module-path-index-join #f #f)))
pi-rel-to)))
(test-rmp (build-path (current-directory) "apple.ss") "apple.ss" #f)
(test-rmp (build-path (current-directory) "apple.ss") "apple.ss" (build-path (current-directory) "x.ss"))
(test-rmp (build-path (current-directory) "apple.ss") "apple.ss" current-directory)
(test-rmp (build-path (current-directory) 'up "apple.ss") "../apple.ss" #f)
(test-rmp (build-path (current-directory) 'up 'up "apple.ss") "../../apple.ss" #f)
(test-rmp (build-path (current-directory) 'same "apple.ss") "./apple.ss" #f)
(test-rmp (build-path (current-directory) "down" "apple.ss") "down/apple.ss" #f)
(test (build-path (current-directory) 'up 'up "apple.ss")
resolve-module-path-index
(module-path-index-join "../apple.ss"
(module-path-index-join "../other.ss"
(module-path-index-join #f #f)))
(build-path (current-directory) "f.ss"))
(test (build-path (current-directory) "only.ss")
resolve-module-path-index
(module-path-index-join #f #f)
(build-path (current-directory) "only.ss"))
(let ([mzlib (collection-path "mzlib")]
[syntax (collection-path "syntax")])
(test-rmp (build-path mzlib "x.ss") '(lib "x.ss") #f)
(test-rmp (build-path mzlib "x.ss") '(lib "x.ss" "mzlib") #f)
(test-rmp (build-path syntax "x.ss") '(lib "x.ss" "syntax") #f)
(test-rmp (build-path syntax "private" "x.ss") '(lib "x.ss" "syntax" "private") #f)
(test-rmp (build-path (current-directory) "x.ss") `(file ,(path->string (build-path (current-directory) "x.ss"))) #f)
(test-rmp (build-path (current-directory) "x.ss") (build-path (current-directory) "x.ss") #f)
(test-rmp (build-path (current-directory) "x.ss") (build-path "x.ss") #f)
(void))
(err/rt-test (resolve-module-path "apple.ss" 'no))
(err/rt-test (resolve-module-path "/apple.ss" #f))
(err/rt-test (resolve-module-path "apple.ss/" #f))
(err/rt-test (resolve-module-path "app\u00E9le.ss" #f))
(err/rt-test (resolve-module-path-index "apple.ss" #f))
(err/rt-test (resolve-module-path-index (module-path-index-join #f #f) #f) exn:fail?)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; collapse-module-path[-index]
(define (test-cmp expect path rel-to)
(test expect collapse-module-path path rel-to)
(test expect collapse-module-path-index
(module-path-index-join path (module-path-index-join #f #f))
rel-to)
(test expect collapse-module-path-index
(module-path-index-join path
(module-path-index-join
"other.ss"
(module-path-index-join #f #f)))
rel-to))
(test-cmp '(lib "./x.ss" "nonesuch") "x.ss" '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "./x.ss" "nonesuch") "x.ss" (lambda () '(lib "y.ss" "nonesuch")))
(test-cmp '(lib "./down/x.ss" "nonesuch") "down/x.ss" '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "./x.ss" "mzlib") '(lib "x.ss") '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "./../x.ss" "nonesuch/private") "../x.ss" '(lib "y.ss" "nonesuch/private"))
(test-cmp '(lib "./private/x.ss" "alsonot") '(lib "x.ss" "alsonot" "private") '(lib "y.ss" "nonesuch"))
(test-cmp (build-path (current-directory) "x.ss") "x.ss" (build-path (current-directory) "other"))
(test-cmp `(file ,(path->string (build-path (current-directory) "x.ss")))
"x.ss"
`(file ,(path->string (build-path (current-directory) "other"))))
(test-cmp (build-path (current-directory) "x.ss")
(build-path "x.ss")
`(file ,(path->string (build-path (current-directory) "other"))))
;; Try path cases that don't fit UTF-8 (and therefore would go wrong as a string):
(let ([dir (build-path (current-directory) (bytes->path #"\xFF"))])
(test-cmp (build-path dir "x.ss")
"x.ss"
(build-path dir "other")))
(test-cmp (build-path (current-directory) (bytes->path #"\xFF"))
(bytes->path #"\xFF")
`(file ,(path->string (build-path (current-directory) "other"))))
(test '(lib "./x.ss" "alsonot")
collapse-module-path-index
(module-path-index-join "x.ss"
(module-path-index-join
'(lib "y.ss" "alsonot")
(module-path-index-join #f #f)))
'(lib "w.ss" "nonesuch"))
(err/rt-test (collapse-module-path "apple.ss" 'no))
(err/rt-test (collapse-module-path "/apple.ss" (current-directory)))
(err/rt-test (collapse-module-path-index "apple.ss" (current-directory)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)