1#lang racket/base
2(require racket/path
3         "modhelp.rkt")
4
5(provide resolve-module-path
6         resolve-module-path-index)
7
8(define (force-relto relto dir? #:path? [path? #t])
9  (let ([relto (if (and (pair? relto)
10                        (eq? (car relto) 'submod))
11                   (cadr relto)
12                   relto)]
13        [submod (if (and (pair? relto)
14                         (eq? (car relto) 'submod))
15                    (cddr relto)
16                    null)])
17    (cond [(path-string? relto)
18           (values (and path?
19                        (if dir?
20                            (let-values ([(base n d?) (split-path relto)])
21                              (when d?
22                                (error 'resolve-module-path-index
23                                       "given a directory path instead of a file path: ~e" relto))
24                              (if (eq? base 'relative)
25                                  (or (current-load-relative-directory) (current-directory))
26                                  base))
27                            relto))
28                   submod)]
29          [(pair? relto) (values relto submod)]
30          [(not dir?)
31           (values
32            (and path?
33                 (error 'resolve-module-path-index
34                        "can't resolve \"self\" with non-path relative-to: ~e" relto))
35            submod)]
36          [(procedure? relto) (force-relto (relto) dir? #:path? path?)]
37          [else (values (and path? (current-directory)) submod)])))
38
39(define (path-ss->rkt p)
40  (if (path-has-extension? p #".ss")
41      (path-replace-extension p #".rkt")
42      p))
43
44(define (combine-submod v p)
45  (if (null? p)
46      v
47      (list* 'submod v p)))
48
49(define (flatten base orig-p)
50  (let loop ([accum '()] [p orig-p])
51    (cond
52     [(null? p) (combine-submod base (reverse accum))]
53     [(equal? (car p) "..")
54      (if (null? accum)
55          (error 'resolve-module-path "too many \"..\"s: ~s"
56                 (combine-submod base orig-p))
57          (loop (cdr accum) (cdr p)))]
58     [else (loop (cons (car p) accum) (cdr p))])))
59
60(define (resolve-module-path s [relto #f])
61  ;; relto should be a complete path, #f, or procedure that returns a
62  ;; complete path
63  (define (get-dir) (force-relto relto #t))
64  (cond [(symbol? s)
65         ;; use resolver handler:
66         (resolved-module-path-name
67          (module-path-index-resolve
68           (module-path-index-join s #f)))]
69        [(string? s)
70         ;; Parse Unix-style relative path string
71         (define-values (dir submod) (get-dir))
72         (path-ss->rkt
73          (apply build-path dir (explode-relpath-string s)))]
74        [(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
75         #f]
76        [(or (path? s) (eq? (car s) 'file))
77         (let ([p (if (path? s) s (expand-user-path (cadr s)))])
78           (define-values (d submod) (get-dir))
79           (path-ss->rkt
80            (path->complete-path
81             p
82             (if (path-string? d)
83                 d
84                 (or (current-load-relative-directory)
85                     (current-directory))))))]
86        [(or (eq? (car s) 'lib)
87             (eq? (car s) 'quote)
88             (eq? (car s) 'planet))
89         ;; use resolver handler in this case, too:
90         (define-values (d submod) (force-relto relto #f #:path? #f))
91         (resolved-module-path-name
92          (module-path-index-resolve
93           (module-path-index-join s #f)))]
94        [(eq? (car s) 'submod)
95         (define r (cond
96                    [(or (equal? (cadr s) ".")
97                         (equal? (cadr s) ".."))
98                     (define-values (d submod) (force-relto relto #f))
99                     (combine-submod d submod)]
100                    [else (resolve-module-path (cadr s) relto)]))
101         (define base-submods (if (and (or (equal? (cadr s) ".")
102                                           (equal? (cadr s) ".."))
103                                       (pair? r))
104                                  (cddr r)
105                                  null))
106         (define base (if (pair? r) (cadr r) r))
107         (flatten base (append base-submods
108                               (if (equal? (cadr s) "..") (cdr s) (cddr s))))]
109        [else #f]))
110
111(define (resolve-module-path-index mpi [relto #f])
112  ;; relto must be a complete path
113  (let-values ([(path base) (module-path-index-split mpi)])
114    (if path
115        (resolve-module-path path (resolve-possible-module-path-index base relto))
116        (let ()
117          (define sm (module-path-index-submodule mpi))
118          (define-values (dir submod) (force-relto relto #f))
119          (combine-submod (path-ss->rkt dir) (if (and sm submod)
120                                                 (append submod sm)
121                                                 (or sm submod)))))))
122
123(define (resolve-possible-module-path-index base [relto #f])
124  (cond [(module-path-index? base)
125         (resolve-module-path-index base relto)]
126        [(and (resolved-module-path? base)
127              (path? (resolved-module-path-name base)))
128         (resolved-module-path-name base)]
129        [relto relto]
130        [else #f]))
131