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