Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

92 lines (66 sloc) 2.437 kb
#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]))])))
Jump to Line
Something went wrong with that request. Please try again.