69 lines
1.9 KiB
Scheme
69 lines
1.9 KiB
Scheme
|
|
(module uri mzscheme
|
|
(require (lib "string.ss")
|
|
(lib "list.ss"))
|
|
(provide uri->symbol
|
|
uri->module-path)
|
|
|
|
(define rx:scheme-uri #rx"^[sS][cC][hH][eE][mM][eE]://([^/]+/+[^/]+.*)$")
|
|
|
|
(define (uri->scheme-path s)
|
|
(let ([m (regexp-match rx:scheme-uri s)])
|
|
(and m
|
|
(let ([l (filter (lambda (s)
|
|
(not (string=? s "")))
|
|
(regexp-split #rx"/" (cadr m)))])
|
|
(let loop ([l l][accum null])
|
|
(cond
|
|
[(null? (cdr l))
|
|
(let ([s (car l)])
|
|
(cons (if (regexp-match #rx"[.]" s)
|
|
s
|
|
(string-append s ".scm"))
|
|
(reverse accum)))]
|
|
[else (loop (cdr l) (cons (car l) accum))]))))))
|
|
|
|
|
|
(define (uri->symbol s)
|
|
(let ([p (uri->scheme-path s)])
|
|
(cond
|
|
[p (string->symbol
|
|
(string-append
|
|
","
|
|
(let ([collpath
|
|
;; Try to get real collection; if it doesn't exist,
|
|
;; make one up relative to mzlib.
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(lambda (exn)
|
|
(simplify-path
|
|
(apply build-path (collection-path "mzlib")
|
|
'up
|
|
(cdr p))))])
|
|
(apply collection-path (cdr p)))])
|
|
(path->string (build-path collpath
|
|
(path-replace-suffix (car p) #""))))))]
|
|
[else (string->symbol
|
|
(string-append ","
|
|
(path->string
|
|
(apply build-path
|
|
(simplify-path
|
|
(expand-path
|
|
;; Don't use (current-load-relative-directory)
|
|
(current-directory)))
|
|
(filter
|
|
(lambda (x)
|
|
(not (string=? x "")))
|
|
(regexp-split #rx"/" s))))))])))
|
|
|
|
(define (uri->module-path s)
|
|
(let ([p (uri->scheme-path s)])
|
|
(cond
|
|
[p
|
|
;; If the collection exists, build a `lib' path. Otherwise, assume
|
|
;; that we're in REPL mode, and make up a symbol using uri->symbol
|
|
(if (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
|
(apply collection-path (cdr p)))
|
|
`(lib ,@p)
|
|
(uri->symbol s))]
|
|
[else s]))))
|