moduledb.rkt (3109B)
1 #lang racket/base 2 (require syntax/modresolve 3 setup/path-to-relative 4 racket/match) 5 (provide allow-bypass? 6 allow-drop? 7 bypass-ok-mpi?) 8 9 (define (allow-bypass? mod) 10 (not (memq (lookup mod) '(no-bypass no-drop)))) 11 12 (define (allow-drop? mod) 13 (not (memq (lookup mod) '(no-drop)))) 14 15 ;; A ModuleDB = hash[path/symbol => (U 'no-drop 'no-bypass)] 16 ;; 'no-drop = must not be dropped or bypassed because of, eg, side effects 17 ;; 'no-bypass = don't bypass in favor of private component modules 18 ;; but if the module is unused, can drop it 19 ;; (FIXME: replace with component module calculation and checking) 20 21 (define (make-module-db no-drop-list no-bypass-list) 22 (let ([mod+config-list 23 (append (for/list ([no-drop (in-list no-drop-list)]) 24 (list no-drop 'no-drop)) 25 (for/list ([no-bypass (in-list no-bypass-list)]) 26 (list no-bypass 'no-bypass)))]) 27 (for/hash ([mod+config (in-list mod+config-list)]) 28 (values (resolve-module-path (car mod+config) #f) (cadr mod+config))))) 29 30 (define (lookup mod) 31 (let ([name (resolved-module-path-name (module-path-index-resolve mod))]) 32 (cond [(symbol? name) 'no-bypass] 33 [(hash-ref module-db name #f) 34 => values] 35 [(path? name) 36 (let ([str (path->relative-string/library name)]) 37 (for/or ([rx (in-list no-bypass-rxs)]) 38 (and (regexp-match? rx str) 'no-bypass)))] 39 [else #f]))) 40 41 ;; module-db : ModuleDB 42 (define module-db 43 (make-module-db 44 ;; no-drop 45 '('#%builtin 46 errortrace 47 scheme/mzscheme ;; introduced by mzscheme's #%module-begin; can't drop 48 racket/contract/private/basic-opters 49 racket/contract/private/opters 50 typed-racket/private/base-env 51 typed-racket/private/base-special-env 52 typed-racket/private/base-env-numeric 53 typed-racket/private/base-env-indexing) 54 ;; no-bypass 55 '(mred 56 mzscheme 57 openssl 58 racket/gui/base 59 racket/match 60 scheme/gui/base 61 slideshow/base 62 string-constants 63 syntax/parse 64 wxme))) 65 66 (define no-bypass-rxs 67 '(#rx"^<collects>/srfi/[0-9]+\\.rkt$")) 68 69 ;; ======================================== 70 71 ;; bypass-ok-mpi? : mpi -> boolean 72 ;; Okay to recommend mod as a replacement in bypass? (heuristic) 73 (define (bypass-ok-mpi? mpi) 74 (define (no-private? s) (not (regexp-match? #rx"private" s))) 75 (define legacy-rxs (list #rx"^mzlib" #rx"^texpict")) 76 (define (ok? s) 77 (and (no-private? s) 78 (for/and ([rx (in-list legacy-rxs)]) 79 (not (regexp-match? rx s))))) 80 (let-values ([(modpath relto) (module-path-index-split mpi)]) 81 (match modpath 82 [(list 'quote name) 83 (not (regexp-match? #rx"^#%" (symbol->string name)))] 84 [(? string?) 85 (ok? modpath)] 86 [(list 'lib parts ...) 87 (andmap ok? parts)] 88 [(? symbol?) 89 (ok? (symbol->string modpath))] 90 [(list 'file part) 91 (ok? part)] 92 [(list 'planet part ...) 93 #t] 94 [(list* 'submod base _) 95 ;; Never bypass to submodules 96 #f])))