58 lines
2.4 KiB
Racket
58 lines
2.4 KiB
Racket
#lang racket/base
|
|
|
|
;; intended for use in racket/contract, so don't try to add contracts!
|
|
;; (and try to generally minimize dependencies)
|
|
|
|
(require "dirs.rkt" "path-relativize.rkt"
|
|
(only-in planet/config [CACHE-DIR find-planet-dir]))
|
|
|
|
(provide make-path->relative-string
|
|
path->relative-string/setup
|
|
path->relative-string/library)
|
|
|
|
(define (make-path->relative-string
|
|
dirs [default (lambda (x) (if (path? x) (path->string x) x))])
|
|
(unless (and (list? dirs)
|
|
(andmap (lambda (x)
|
|
(and (pair? x)
|
|
(and (procedure? (car x))
|
|
(procedure-arity-includes? (car x) 0)
|
|
(string? (cdr x)))))
|
|
dirs))
|
|
(raise-type-error 'make-path->relative-string
|
|
"a list of thunk and string pairs" dirs))
|
|
(define prefixes (map cdr dirs))
|
|
(define path->relatives
|
|
(map (lambda (x)
|
|
(let-values ([(path->relative _)
|
|
(make-relativize (car x) '_ 'path->relative '_)])
|
|
path->relative))
|
|
dirs))
|
|
(define (path->relative-string path [default default])
|
|
(unless (path-string? path)
|
|
(raise-type-error 'path->relative-string "path or string" path))
|
|
(or (and (complete-path? path)
|
|
(for/or ([prefix (in-list prefixes)]
|
|
[path->relative (in-list path->relatives)])
|
|
(define exploded (path->relative path))
|
|
(and (pair? exploded)
|
|
(let* ([r (cdr exploded)]
|
|
;; note: use "/"s, to get paths as in `require's
|
|
[r (map (lambda (p) (list #"/" p)) r)]
|
|
[r (apply bytes-append (cdr (apply append r)))])
|
|
(string-append prefix (bytes->string/locale r))))))
|
|
(if (procedure? default) (default path) default)))
|
|
path->relative-string)
|
|
|
|
(define path->relative-string/library
|
|
(make-path->relative-string
|
|
(list (cons find-collects-dir "<collects>/")
|
|
(cons find-user-collects-dir "<user-collects>/")
|
|
(cons find-planet-dir "<planet>/"))))
|
|
|
|
(define path->relative-string/setup
|
|
(make-path->relative-string
|
|
(list (cons find-collects-dir "")
|
|
(cons find-user-collects-dir "<user>/")
|
|
(cons find-planet-dir "<planet>/"))))
|