177 lines
6.0 KiB
Racket
177 lines
6.0 KiB
Racket
#lang racket/base
|
|
(require racket/path
|
|
racket/match
|
|
syntax/modcode
|
|
syntax/modresolve
|
|
syntax/modcollapse
|
|
macro-debugger/model/trace)
|
|
|
|
;; --------
|
|
|
|
(provide (struct-out ref)
|
|
mode->nat
|
|
(struct-out imp)
|
|
ref->imp)
|
|
|
|
;; A Ref is (ref phase id/#f identifier-binding Mode)
|
|
;; the def-mod, def-sym, etc parts of identifier-binding may be #f (eg, provide)
|
|
(struct ref (phase id mode binding))
|
|
|
|
;; A Mode is one of '(reference syntax-local-value quote-syntax disappeared-use provide)
|
|
(define (mode->nat mode)
|
|
(case mode
|
|
((reference) 0)
|
|
((provide) 1)
|
|
((syntax-local-value) 2)
|
|
((quote-syntax) 3)
|
|
((disappeared-use) 4)
|
|
(else (error 'mode->nat "bad mode: ~s" mode))))
|
|
|
|
;; An Imp is (imp mpi phase symbol phase Ref)
|
|
(struct imp (mod reqphase sym exp-phase ref))
|
|
;; interpretation: reference ref could be satisfied by
|
|
;; (require (only (for-meta reqphase (just-meta exp-phase mod)) sym))
|
|
|
|
;; ref->imp : Ref -> Imp
|
|
;; Assumes id gotten from nom-mod, etc.
|
|
(define (ref->imp r)
|
|
(match (ref-binding r)
|
|
[(list _dm _ds nom-mod nom-sym _dp imp-shift nom-orig-phase)
|
|
(imp nom-mod imp-shift nom-sym nom-orig-phase r)]))
|
|
|
|
;; --------
|
|
|
|
(provide get-module-code/trace
|
|
here-mpi?
|
|
mpi->key
|
|
mpi->list
|
|
mpi-list->module-path)
|
|
|
|
;; get-module-derivation : module-path -> (values compiled Deriv)
|
|
(define (get-module-code/trace modpath)
|
|
(let-values ([(path subs)
|
|
(match (resolve-module-path modpath #f)
|
|
[`(submod ,path . ,subs) (values path subs)]
|
|
[path (values path null)])])
|
|
(get-module-code path
|
|
#:submodule-path subs
|
|
#:choose (lambda _ 'src)
|
|
#:compile (lambda (stx)
|
|
(let-values ([(stx deriv) (trace/result stx expand)])
|
|
(values (compile stx) deriv))))))
|
|
|
|
;; here-mpi? : any -> boolean
|
|
(define (here-mpi? x)
|
|
(and (module-path-index? x)
|
|
(let-values ([(rel base) (module-path-index-split x)])
|
|
(and (eq? rel #f) (eq? base #f)))))
|
|
|
|
(define (mpi->key x)
|
|
(let ([l (mpi->list x)])
|
|
(if (and (pair? l) (null? (cdr l)))
|
|
(car l)
|
|
l)))
|
|
|
|
(define (mpi->list x)
|
|
(cond [(module-path-index? x)
|
|
(let-values ([(rel base) (module-path-index-split x)])
|
|
(if rel
|
|
(cons rel (mpi->list base))
|
|
null))]
|
|
[(eq? x #f)
|
|
null]
|
|
[else
|
|
(list x)]))
|
|
|
|
(define (mpi-list->module-path mpi-list)
|
|
(let* ([mpi*
|
|
(let loop ([mpi #f] [mpi-list mpi-list])
|
|
(cond [mpi
|
|
(let-values ([(mod base) (module-path-index-split mpi)])
|
|
(cond [mod (module-path-index-join mod (loop base mpi-list))]
|
|
[else (loop #f mpi-list)]))]
|
|
[(pair? mpi-list)
|
|
(loop (car mpi-list) (cdr mpi-list))]
|
|
[else #f]))]
|
|
[collapsed
|
|
(let loop ([mpi mpi*])
|
|
(cond [mpi
|
|
(let-values ([(mod base) (module-path-index-split mpi)])
|
|
(cond [mod
|
|
(collapse-module-path mod (lambda () (loop base)))]
|
|
[else (build-path 'same)]))]
|
|
[else (build-path 'same)]))])
|
|
(let simplify ([collapsed collapsed])
|
|
(match collapsed
|
|
[(list* 'submod base subs)
|
|
(list* 'submod (simplify base) subs)]
|
|
[(list 'lib str)
|
|
(cond [(regexp-match? #rx"\\.rkt$" str)
|
|
(let* ([no-suffix (path->string (path-replace-suffix str ""))]
|
|
[no-main
|
|
(cond [(regexp-match #rx"^([^/]+)/main$" no-suffix)
|
|
=> cadr]
|
|
[else no-suffix])])
|
|
(string->symbol no-main))]
|
|
[else collapsed])]
|
|
[(? path?)
|
|
(path->string (simplify-path collapsed #f))] ;; to get rid of "./" at beginning
|
|
[_ collapsed]))))
|
|
|
|
;; --------
|
|
|
|
(provide get-module-imports
|
|
get-module-exports
|
|
get-module-var-exports
|
|
get-module-stx-exports
|
|
get-module-all-exports)
|
|
|
|
(struct modinfo (imports var-exports stx-exports) #:prefab)
|
|
|
|
;; cache : hash[path/symbol => modinfo]
|
|
(define cache (make-hash))
|
|
|
|
;; get-module-info/no-cache : path -> modinfo
|
|
(define (get-module-info/no-cache resolved)
|
|
(let ([compiled (get-module-code resolved)])
|
|
(let-values ([(imports) (module-compiled-imports compiled)]
|
|
[(var-exports stx-exports) (module-compiled-exports compiled)])
|
|
(parameterize ((current-directory (path-only resolved)))
|
|
(force-all-mpis imports)
|
|
(force-all-mpis (cons var-exports stx-exports)))
|
|
(modinfo imports var-exports stx-exports))))
|
|
|
|
;; get-module-info : (or module-path module-path-index) -> modinfo
|
|
(define (get-module-info mod)
|
|
(let ([resolved (resolve mod)])
|
|
(hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved)))))
|
|
|
|
;; resolve : (or module-path module-path-index) -> path
|
|
(define (resolve mod)
|
|
(cond [(module-path-index? mod)
|
|
(resolved-module-path-name (module-path-index-resolve mod))]
|
|
[else (resolve-module-path mod #f)]))
|
|
|
|
(define (get-module-imports path)
|
|
(modinfo-imports (get-module-info path)))
|
|
(define (get-module-var-exports path)
|
|
(modinfo-var-exports (get-module-info path)))
|
|
(define (get-module-stx-exports path)
|
|
(modinfo-stx-exports (get-module-info path)))
|
|
(define (get-module-exports path)
|
|
(let ([info (get-module-info path)])
|
|
(values (modinfo-var-exports info) (modinfo-stx-exports info))))
|
|
(define (get-module-all-exports path)
|
|
(append (get-module-var-exports path)
|
|
(get-module-stx-exports path)))
|
|
|
|
(define (force-all-mpis x)
|
|
(let loop ([x x])
|
|
(cond [(pair? x)
|
|
(loop (car x))
|
|
(loop (cdr x))]
|
|
[(module-path-index? x)
|
|
;; uses current-directory, hopefully
|
|
(module-path-index-resolve x)]
|
|
[else (void)])))
|