92 lines
2.4 KiB
Racket
92 lines
2.4 KiB
Racket
#lang racket/base
|
|
|
|
(require "../parameters.rkt"
|
|
"where-is-collects.rkt"
|
|
racket/path
|
|
racket/contract
|
|
racket/list
|
|
racket/runtime-path
|
|
racket/string)
|
|
|
|
|
|
|
|
(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]
|
|
[within-root-path? (complete-path? . -> . boolean?)]
|
|
[within-whalesong-path? (complete-path? . -> . boolean?)])
|
|
|
|
|
|
|
|
(define-runtime-path whalesong-path "..")
|
|
(define normal-whalesong-path
|
|
(let ()
|
|
(normalize-path whalesong-path)))
|
|
|
|
|
|
|
|
|
|
;; The path rewriter takes paths and provides a canonical symbol for
|
|
;; it. Paths located within collects get remapped to collects, those
|
|
;; within the compiler directory mapped to "whalesong", those within
|
|
;; the root to "root". If none of these work, we return #f.
|
|
|
|
|
|
;; rewrite-path: path -> (symbol #f)
|
|
(define (rewrite-path a-path)
|
|
(let ([a-path (normalize-path a-path)])
|
|
(cond
|
|
[(within-whalesong-path? a-path)
|
|
(string->symbol
|
|
(string-append "whalesong/"
|
|
(my-path->string
|
|
(find-relative-path normal-whalesong-path a-path))))]
|
|
[(within-collects? a-path)
|
|
(string->symbol
|
|
(string-append "collects/"
|
|
(my-path->string
|
|
(find-relative-path collects-path a-path))))]
|
|
[(within-root-path? a-path)
|
|
(string->symbol
|
|
(string-append "root/"
|
|
(my-path->string
|
|
(find-relative-path (current-root-path) a-path))))]
|
|
[else
|
|
#f])))
|
|
|
|
|
|
|
|
;; Like path->string, but I force the path separator to be '/' rather than the platform
|
|
;; specific one.
|
|
(define (my-path->string a-path)
|
|
(string-join (map path->string (explode-path a-path)) "/"))
|
|
|
|
|
|
|
|
|
|
(define (within-root-path? a-path)
|
|
(within? (current-root-path) a-path))
|
|
|
|
|
|
(define (within-collects? a-path)
|
|
(within? collects-path a-path))
|
|
|
|
|
|
(define (within-whalesong-path? a-path)
|
|
(within? normal-whalesong-path a-path))
|
|
|
|
|
|
;; within?: normalized-path normalized-path -> boolean
|
|
;; Produces true if a-path is within the base.
|
|
(define (within? base a-path)
|
|
(let ([rp (find-relative-path base a-path)])
|
|
(cond
|
|
[(equal? rp a-path)
|
|
#f]
|
|
[else
|
|
(let ([chunks (explode-path rp)])
|
|
(cond
|
|
[(empty? chunks)
|
|
#t]
|
|
[(eq? (first chunks) 'up)
|
|
#f]
|
|
[else
|
|
#t]))]))) |