105 lines
3.2 KiB
Scheme
105 lines
3.2 KiB
Scheme
|
|
#lang scheme/base
|
|
(require (for-syntax scheme/base)
|
|
scheme/match
|
|
syntax/boundmap
|
|
"reductions-config.ss")
|
|
(provide make-policy
|
|
standard-policy
|
|
base-policy
|
|
hide-all-policy
|
|
hide-none-policy)
|
|
|
|
;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
|
|
;; -> identifier -> bool
|
|
(define (make-policy hide-mzscheme?
|
|
hide-libs?
|
|
hide-contracts?
|
|
hide-transformers?
|
|
specialized-policies)
|
|
(lambda (id)
|
|
(define now (phase))
|
|
(define binding
|
|
(cond [(= now 0) (identifier-binding id)]
|
|
[(= now 1) (identifier-transformer-binding id)]
|
|
[else #f]))
|
|
(define-values (def-mod def-name nom-mod nom-name)
|
|
(if (pair? binding)
|
|
(values (car binding)
|
|
(cadr binding)
|
|
(caddr binding)
|
|
(cadddr binding))
|
|
(values #f #f #f #f)))
|
|
(let/ec return
|
|
(let loop ([policies specialized-policies])
|
|
(when (pair? policies)
|
|
((car policies) id binding return)
|
|
(loop (cdr policies))))
|
|
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
|
|
#f]
|
|
[(and hide-libs? def-mod (lib-module? def-mod))
|
|
#f]
|
|
[(and hide-contracts? def-name
|
|
(regexp-match #rx"^provide/contract-id-"
|
|
(symbol->string def-name)))
|
|
#f]
|
|
[(and hide-transformers? (positive? now))
|
|
#f]
|
|
[else #t]))))
|
|
|
|
(define standard-policy
|
|
(make-policy #t #t #t #t null))
|
|
|
|
(define base-policy
|
|
(make-policy #t #f #f #f null))
|
|
|
|
(define (hide-all-policy id) #f)
|
|
(define (hide-none-policy id) #t)
|
|
|
|
|
|
;;
|
|
|
|
(define (scheme-module? mpi)
|
|
(let ([abs (find-absolute-module-path mpi)])
|
|
(and abs
|
|
(or (base-module-path? abs)
|
|
(scheme-lib-module-path? abs)))))
|
|
|
|
(define (lib-module? mpi)
|
|
(let ([abs (find-absolute-module-path mpi)])
|
|
(and abs (lib-module-path? abs))))
|
|
|
|
|
|
(define (find-absolute-module-path mpi)
|
|
(and (module-path-index? mpi)
|
|
(let-values ([(path rel) (module-path-index-split mpi)])
|
|
(cond [(and (pair? path) (memq (car path) '(quote lib planet)))
|
|
path]
|
|
[(symbol? path) path]
|
|
[(string? path) (find-absolute-module-path rel)]
|
|
[else #f]))))
|
|
|
|
(define (base-module-path? mp)
|
|
(and (pair? mp)
|
|
(eq? 'quote (car mp))
|
|
(regexp-match #rx"^#%" (symbol->string (cadr mp)))))
|
|
|
|
(define (scheme-lib-module-path? mp)
|
|
(cond [(symbol? mp)
|
|
(scheme-collection-name? (symbol->string mp))]
|
|
[(and (pair? mp) (eq? (car mp) 'lib))
|
|
(cond [(string? (cadr mp)) (null? (cddr mp))
|
|
(scheme-collection-name? (cadr mp))]
|
|
[(symbol? (cadr mp))
|
|
(scheme-collection-name? (symbol->string (cadr mp)))]
|
|
[else #f])]
|
|
[else #f]))
|
|
|
|
(define (scheme-collection-name? path)
|
|
(or (regexp-match? #rx"^scheme/base(/.)?" path)
|
|
(regexp-match? #rx"^mzscheme(/.)?" path)))
|
|
|
|
(define (lib-module-path? mp)
|
|
(or (symbol? mp)
|
|
(and (pair? mp) (memq (car mp) '(lib planet)))))
|