1#lang racket/base 2(require racket/promise) 3 4(provide make-relativize) 5 6(define (make-relativize find-roots-dir ; can return #f, one path, or a list of paths to try 7 tag 8 to-rel-name 9 from-rel-name) 10 11 ;; Historical note: this module is based on the old "plthome.ss" 12 13 ;; The `path->relative' and `relative->path' functions that this 14 ;; generates are used to store paths that are relative to the root 15 ;; directory (specified by `find-root-dir'), such as in .dep files. 16 ;; This means that if the racket tree is moved, .dep files still 17 ;; work. It is generally fine if `path->relative' misses some 18 ;; usages, as long as it works when we prepare a distribution tree. 19 ;; (If it misses, things will continue to work fine and .dep files 20 ;; will contain absolute path names.) 21 22 ;; If `find-roots-dir` returns a list of roots, then a path is 23 ;; converted as relative for the first root path where that's 24 ;; possible, and a relative is converted back to a path for the 25 ;; first one that exists (as a file, directory, or link) or 26 ;; the first one if none exists. An empty roots list and a #f 27 ;; from `find-root-dir` are treated as the same. 28 29 ;; We need to compare paths to find when something is in the racket 30 ;; tree, so we explode the paths. This is slower than the old way 31 ;; (by a factor of 2 or so), but it's simpler and more portable. 32 (define (explode-path* path) 33 (explode-path (simplify-path (path->complete-path path)))) 34 35 (define exploded-roots 36 (delay (cond [(find-roots-dir) 37 => (lambda (p) 38 (if (list? p) 39 (map explode-path* p) 40 (list (explode-path* p))))] 41 [else '()]))) 42 43 ;; path->relative : path-or-bytes -> datum-containing-bytes-or-path 44 (define (path->relative path0) 45 (define path1 46 (cond [(bytes? path0) (bytes->path path0)] 47 [(path-string? path0) path0] 48 [else (raise-argument-error to-rel-name 49 "(or/c path-string? bytes?)" 50 path0)])) 51 (define orig-path (explode-path* path1)) 52 (define roots (force exploded-roots)) 53 (let loop ([path orig-path] 54 [root (and (pair? roots) (car roots))] 55 [roots (if (pair? roots) (cdr roots) '())]) 56 (cond [(not root) path0] 57 [(null? root) (cons tag (map (lambda (pe) 58 (datum-intern-literal 59 (path-element->bytes pe))) 60 path))] 61 ;; Note: in some cases this returns the input path as is, which 62 ;; could be a byte string -- it should be possible to return 63 ;; `path1', but that messes up the xform compilation somehow, by 64 ;; having #<path...> values written into dep files. 65 [(null? path) 66 (cond 67 [(null? roots) path0] 68 [else (loop orig-path (car roots) (cdr roots))])] 69 [(equal? (normal-case-path (car path)) (normal-case-path (car root))) 70 (loop (cdr path) (cdr root) roots)] 71 [else 72 (cond 73 [(null? roots) path0] 74 [else (loop orig-path (car roots) (cdr roots))])]))) 75 76 (define roots-or-orig 77 (delay (or (let ([r (find-roots-dir)]) 78 (and r 79 (if (list? r) 80 (and (pair? r) r) 81 (list r)))) 82 ;; No main "collects"/"doc"/whatever => use the 83 ;; original working directory: 84 (list (find-system-path 'orig-dir))))) 85 86 ;; relative->path : datum-containing-bytes-or-path -> path 87 (define (relative->path path) 88 (cond [(and (pair? path) (eq? tag (car path)) 89 (and (list? (cdr path)) (andmap bytes? (cdr path)))) 90 (define roots (force roots-or-orig)) 91 (define elems (map bytes->path-element (cdr path))) 92 (define default-p (apply build-path (car roots) elems)) 93 (define (exists? p) (file-or-directory-type p)) 94 (cond 95 [(or (null? (cdr roots)) 96 (exists? default-p)) 97 default-p] 98 [else 99 (let loop ([roots (cdr roots)]) 100 (cond 101 [(null? roots) default-p] 102 [else 103 (define p (apply build-path (car roots) elems)) 104 (or (and (exists? p) 105 p) 106 (loop (cdr roots)))]))])] 107 [(path? path) path] 108 [(bytes? path) (bytes->path path)] 109 [(string? path) (string->path path)] 110 [else (raise-argument-error 111 from-rel-name 112 (format "(or/c path? bytes? (cons '~a (non-empty-listof bytes?)))" tag) 113 path)])) 114 115 (values path->relative relative->path)) 116