50 lines
1.6 KiB
Scheme
50 lines
1.6 KiB
Scheme
|
|
(module util mzscheme
|
|
(require (lib "class.ss"))
|
|
(provide with-unlock
|
|
mpi->string
|
|
mpi->list)
|
|
|
|
(define-syntax with-unlock
|
|
(syntax-rules ()
|
|
[(with-unlock text . body)
|
|
(let* ([t text]
|
|
[locked? (send t is-locked?)])
|
|
(send t lock #f)
|
|
(begin0 (let () . body)
|
|
(send t lock locked?)))]))
|
|
|
|
(define (mpi->string mpi)
|
|
(if (module-path-index? mpi)
|
|
(let ([mps (mpi->list mpi)])
|
|
(cond [(and (pair? mps) (pair? (cdr mps)))
|
|
(apply string-append
|
|
(format "~s" (car mps))
|
|
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
|
|
[(and (pair? mps) (null? (cdr mps)))
|
|
(format "~s" (car mps))]
|
|
[(null? mps) "self"]))
|
|
(format "~s" mpi)))
|
|
|
|
(define (mpi->list mpi)
|
|
(if mpi
|
|
(let-values ([(path rel) (module-path-index-split mpi)])
|
|
(if (and (pair? path) (memq (car path) '(file lib planet)))
|
|
(cons path null)
|
|
(cons path (mpi->list rel))))
|
|
'()))
|
|
|
|
; ;; mpi->string : module-path-index -> string
|
|
; ;; Human-readable form of module-path-index
|
|
; (define (mpi->string x)
|
|
; (cond [(module-path-index? x)
|
|
; (let-values ([(path base) (module-path-index-split x)])
|
|
; (cond [(eq? path #f)
|
|
; "self module"]
|
|
; [(eq? base #f)
|
|
; (format "top-level => ~a" path)]
|
|
; [else
|
|
; (format "~a => ~a" (mpi->string base) path)]))]
|
|
; [else x]))
|
|
|
|
) |