path rewriter knows about main js-sicp project path

This commit is contained in:
Danny Yoo 2011-05-13 15:43:44 -04:00
parent 9988201d06
commit db302a1b0c

View File

@ -2,7 +2,8 @@
(require racket/path (require racket/path
racket/contract racket/contract
racket/list) racket/list
racket/runtime-path)
@ -13,8 +14,15 @@
(define-runtime-path this-path ".")
(define this-normal-path
(let ()
(normalize-path this-path)))
(define current-root-path (define current-root-path
(make-parameter (current-directory))) (make-parameter (normalize-path (current-directory))))
;; The path rewriter takes paths and provides a canonical symbol for it. ;; The path rewriter takes paths and provides a canonical symbol for it.
@ -25,16 +33,21 @@
(define (rewrite-path a-path) (define (rewrite-path a-path)
(let ([a-path (normalize-path a-path)]) (let ([a-path (normalize-path a-path)])
(cond (cond
[(within-collects? a-path)
(string->symbol
(string-append "collects/"
(path->string
(find-relative-path collects a-path))))]
[(within-root? a-path) [(within-root? a-path)
(string->symbol (string->symbol
(string-append "root/" (string-append "root/"
(path->string (path->string
(find-relative-path (current-root-path) a-path))))] (find-relative-path (current-root-path) a-path))))]
[(within-collects? a-path)
(string->symbol
(string-append "collects/"
(path->string
(find-relative-path collects a-path))))]
[(within-this-project-path? a-path)
(string->symbol
(string-append "js-vm/"
(path->string
(find-relative-path this-normal-path a-path))))]
[else [else
#f]))) #f])))
@ -59,6 +72,10 @@
(within? collects a-path)) (within? collects a-path))
(define (within-this-project-path? a-path)
(within? this-normal-path a-path))
;; within?: normalized-path normalized-path -> boolean ;; within?: normalized-path normalized-path -> boolean
;; Produces true if a-path is within the base. ;; Produces true if a-path is within the base.
(define (within? base a-path) (define (within? base a-path)