Avoid changing the parameter value, so it is possible to extend it.

This commit is contained in:
Eli Barzilay 2010-06-26 16:40:12 -04:00
parent fdb8751de3
commit 95c49e138e

View File

@ -43,25 +43,31 @@
;; 'abs is used below for roots that should always use absolute links (needed ;; 'abs is used below for roots that should always use absolute links (needed
;; for some skeleton pages that are used in nested subdirectories). ;; for some skeleton pages that are used in nested subdirectories).
(provide url-roots) (provide url-roots)
(define url-roots (define url-roots (make-parameter #f))
(define cached-roots '(#f . #f))
(define (current-url-roots)
;; takes in a (listof (list prefix-string url-string . flags)), and produces ;; takes in a (listof (list prefix-string url-string . flags)), and produces
;; an alist with lists of strings for the keys; the prefix-strings are split ;; an alist with lists of strings for the keys; the prefix-strings are split
;; on "/"s, and the url-strings can be anything at all actually (they are put ;; on "/"s, and the url-strings can be anything at all actually (they are put
;; as-is before the path with a "/" between them). ;; as-is before the path with a "/" between them).
(make-parameter #f (let ([roots (url-roots)])
(lambda (x) (unless (eq? roots (car cached-roots))
(and (list? x) (pair? x) (set! cached-roots
(map (lambda (x) (cons roots
(list* (regexp-match* #rx"[^/]+" (car x)) (and (list? roots) (pair? roots)
(regexp-replace #rx"/$" (cadr x) "") (map (lambda (root)
(cddr x))) (list* (regexp-match* #rx"[^/]+" (car root))
x))))) (regexp-replace #rx"/$" (cadr root) "")
(cddr root)))
roots)))))
(cdr cached-roots)))
;; a utility for relative paths, taking the above `default-file' and ;; a utility for relative paths, taking the above `default-file' and
;; `url-roots' into consideration. ;; `url-roots' into consideration.
(define (relativize file tgtdir curdir) (define (relativize file tgtdir curdir)
(define file* (if (equal? file default-file) "" file)) (define file* (if (equal? file default-file) "" file))
(define roots (url-roots)) (define roots (current-url-roots))
(define (find-root path mode) (define (find-root path mode)
(ormap (lambda (root+url+flags) (ormap (lambda (root+url+flags)
(let loop ([r (car root+url+flags)] [p path]) (let loop ([r (car root+url+flags)] [p path])