util.rkt (8143B)
1 #lang racket/base 2 (require racket/path 3 racket/list 4 racket/match 5 syntax/modcode 6 syntax/modresolve 7 syntax/modcollapse 8 macro-debugger/model/trace) 9 10 ;; -------- 11 12 (provide (struct-out ref) 13 mode->nat 14 (struct-out imp) 15 ref->imp) 16 17 ;; A Ref is (ref phase id/#f identifier-binding Mode) 18 ;; the def-mod, def-sym, etc parts of identifier-binding may be #f (eg, provide) 19 (struct ref (phase id mode binding)) 20 21 ;; A Mode is one of '(reference syntax-local-value quote-syntax disappeared-use provide) 22 (define (mode->nat mode) 23 (case mode 24 ((reference) 0) 25 ((provide) 1) 26 ((syntax-local-value) 2) 27 ((quote-syntax) 3) 28 ((disappeared-use) 4) 29 (else (error 'mode->nat "bad mode: ~s" mode)))) 30 31 ;; An Imp is (imp mpi phase symbol phase Ref) 32 (struct imp (mod reqphase sym exp-phase ref)) 33 ;; interpretation: reference ref could be satisfied by 34 ;; (require (only (for-meta reqphase (just-meta exp-phase mod)) sym)) 35 36 ;; ref->imp : Ref -> Imp 37 ;; Assumes id gotten from nom-mod, etc. 38 (define (ref->imp r) 39 (match (ref-binding r) 40 [(list _dm _ds nom-mod nom-sym _dp imp-shift nom-orig-phase) 41 (imp nom-mod imp-shift nom-sym nom-orig-phase r)])) 42 43 ;; -------- 44 45 (provide get-module-code/trace 46 here-mpi? 47 mpi->key 48 mpi->list 49 mpi-list->module-path) 50 51 ;; get-module-derivation : module-path -> (values compiled Deriv) 52 (define (get-module-code/trace modpath) 53 (let-values ([(path subs) 54 (match (resolve-module-path modpath #f) 55 [`(submod ,path . ,subs) (values path subs)] 56 [path (values path null)])]) 57 (get-module-code path 58 #:submodule-path subs 59 #:choose (lambda _ 'src) 60 #:compile (lambda (stx) 61 (let-values ([(stx deriv) (trace/result stx expand)]) 62 (values (compile stx) deriv)))))) 63 64 ;; here-mpi? : any -> boolean 65 (define (here-mpi? x) 66 (and (module-path-index? x) 67 (let-values ([(rel base) (module-path-index-split x)]) 68 (and (eq? rel #f) (eq? base #f))))) 69 70 (define (mpi->key x) 71 (let ([l (mpi->list x)]) 72 (if (and (pair? l) (null? (cdr l))) 73 (car l) 74 l))) 75 76 (define (mpi->list x) 77 (cond [(module-path-index? x) 78 (let-values ([(rel base) (module-path-index-split x)]) 79 (if rel 80 (cons rel (mpi->list base)) 81 null))] 82 [(eq? x #f) 83 null] 84 [else 85 (list x)])) 86 87 (define (mpi-list->module-path mpi-list) 88 (let* ([mpi* 89 (let loop ([mpi #f] [mpi-list mpi-list]) 90 (cond [mpi 91 (let-values ([(mod base) (module-path-index-split mpi)]) 92 (cond [mod (module-path-index-join mod (loop base mpi-list))] 93 [else (loop #f mpi-list)]))] 94 [(pair? mpi-list) 95 (loop (car mpi-list) (cdr mpi-list))] 96 [else #f]))] 97 [collapsed 98 (let loop ([mpi mpi*]) 99 (cond [mpi 100 (let-values ([(mod base) (module-path-index-split mpi)]) 101 (cond [mod 102 (collapse-module-path mod (lambda () (loop base)))] 103 [else (build-path 'same)]))] 104 [else (build-path 'same)]))]) 105 (let simplify ([collapsed collapsed]) 106 (match collapsed 107 [(list* 'submod base subs) 108 (list* 'submod (simplify base) subs)] 109 [(list 'lib str) 110 (cond [(regexp-match? #rx"\\.rkt$" str) 111 (let* ([no-suffix (path->string (path-replace-suffix str ""))] 112 [no-main 113 (cond [(regexp-match #rx"^([^/]+)/main$" no-suffix) 114 => cadr] 115 [else no-suffix])]) 116 (string->symbol no-main))] 117 [else collapsed])] 118 [(? path?) 119 (path->string (simplify-path collapsed #f))] ;; to get rid of "./" at beginning 120 [_ collapsed])))) 121 122 ;; -------- 123 124 (provide get-module-imports 125 get-module-exports 126 get-module-var-exports 127 get-module-stx-exports 128 get-module-all-exports) 129 130 (struct modinfo (imports var-exports stx-exports imports/r var-exports/r stx-exports/r) 131 #:prefab) 132 133 ;; cache : hash[path/symbol/list => modinfo] 134 (define cache (make-hash)) 135 136 ;; get-module-code* : (U path (cons path (listof symbol))) -> compiled-module 137 (define (get-module-code* resolved) 138 (let* ([path (if (pair? resolved) (car resolved) resolved)] 139 [subs (if (pair? resolved) (cdr resolved) null)] 140 [code (get-module-code path)]) 141 (for/fold ([code code]) ([submod-name (in-list subs)]) 142 (define (choose-submod? sub) 143 (let* ([sub-name (module-compiled-name sub)]) 144 (equal? (last sub-name) submod-name))) 145 (or (for/or ([sub (in-list (module-compiled-submodules code #t))]) 146 (and (choose-submod? sub) sub)) 147 (for/or ([sub (in-list (module-compiled-submodules code #f))]) 148 (and (choose-submod? sub) sub)) 149 (error 'get-module-code* "couldn't get code for: ~s" resolved))))) 150 151 ;; get-module-info/no-cache : path -> modinfo 152 (define (get-module-info/no-cache resolved) 153 (let ([compiled (get-module-code* resolved)] 154 [resolved-base (if (pair? resolved) (car resolved) resolved)]) 155 (let-values ([(imports) (module-compiled-imports compiled)] 156 [(var-exports stx-exports) (module-compiled-exports compiled)] 157 [(dir) (path-only (if (pair? resolved) (car resolved) resolved))]) 158 (parameterize ((current-directory dir) 159 (current-load-relative-directory dir)) 160 (force-all-mpis imports) 161 (force-all-mpis (cons var-exports stx-exports))) 162 (modinfo imports var-exports stx-exports 163 (resolve-all-mpis imports resolved-base) 164 (resolve-all-mpis var-exports resolved-base) 165 (resolve-all-mpis stx-exports resolved-base))))) 166 167 ;; get-module-info : (or module-path module-path-index) -> modinfo 168 (define (get-module-info mod) 169 (let ([resolved (resolve mod)]) 170 (when #f 171 (eprintf "fetch ~s => ~s\n" 172 (if (module-path-index? mod) (cons 'mpi (mpi->list mod)) mod) 173 resolved)) 174 (hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved))))) 175 176 ;; resolve : (or module-path resolved-module-path module-path-index) 177 ;; -> (U (U path symbol) (cons (U path symbol) (listof symbol))) 178 (define (resolve mod) 179 (cond [(module-path-index? mod) 180 (resolved-module-path-name (module-path-index-resolve mod))] 181 [(resolved-module-path? mod) 182 (resolved-module-path-name mod)] 183 [else (resolve-module-path mod #f)])) 184 185 (define (get-module-imports path #:resolve? [resolve? #f]) 186 ((if resolve? modinfo-imports/r modinfo-imports) (get-module-info path))) 187 (define (get-module-var-exports path #:resolve? [resolve? #f]) 188 ((if resolve? modinfo-var-exports/r modinfo-var-exports) (get-module-info path))) 189 (define (get-module-stx-exports path #:resolve? [resolve? #f]) 190 ((if resolve? modinfo-stx-exports/r modinfo-stx-exports) (get-module-info path))) 191 (define (get-module-exports path #:resolve? [resolve? #f]) 192 (values (get-module-var-exports path #:resolve? resolve?) 193 (get-module-stx-exports path #:resolve? resolve?))) 194 (define (get-module-all-exports path #:resolve? [resolve? #f]) 195 (append (get-module-var-exports path #:resolve? resolve?) 196 (get-module-stx-exports path #:resolve? resolve?))) 197 198 (define (resolve-all-mpis x base) 199 (let loop ([x x]) 200 (cond [(pair? x) 201 (cons (loop (car x)) (loop (cdr x)))] 202 [(module-path-index? x) 203 (resolve-module-path-index x base)] 204 [else x]))) 205 206 (define (force-all-mpis x) 207 (let loop ([x x]) 208 (cond [(pair? x) 209 (loop (car x)) 210 (loop (cdr x))] 211 [(module-path-index? x) 212 ;; uses current-directory, hopefully 213 (module-path-index-resolve x)] 214 [else (void)])))