/usr/share/racket/collects/setup/path-to-relative.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | #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])
pkg/path)
(provide make-path->relative-string
path->relative-string/library
path->relative-string/setup)
(define default-default (lambda (x) (if (path? x) (path->string x) x)))
(define (make-path->relative-string dirs [default default-default])
(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 (let ([l (apply append r)])
(if (pair? l)
(cdr l)
null)))])
(string-append prefix (bytes->string/locale r))))))
(if (procedure? default) (default path) default)))
path->relative-string)
(define path->relative-string/library
(let ()
(define p->r
(make-path->relative-string
(list (cons find-collects-dir "<collects>/")
(cons find-user-collects-dir "<user>/")
(cons find-planet-dir "<planet>/")
(cons find-doc-dir "<doc>/")
(cons find-user-doc-dir "<user-doc>/"))))
(define (make-default cache default)
(lambda (x)
(define-values (pkg sub) (if (complete-path? x)
(path->pkg+subpath x #:cache cache)
(values #f #f)))
(cond
[pkg
(apply string-append
"<pkgs>" "/" pkg
(if (eq? sub 'same)
null
(let loop ([l (explode-path sub)])
(cond
[(null? l) null]
[else (list* "/"
(path-element->string (car l))
(loop (cdr l)))]))))]
[(path? x) (path->string x)]
[else (if (procedure? default) (default x) default)])))
(lambda (x [default default-default] #:cache [cache #f])
(p->r x (make-default cache default)))))
(define path->relative-string/setup path->relative-string/library)
|