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