277 lines
10 KiB
Racket
277 lines
10 KiB
Racket
#lang at-exp racket/base
|
|
|
|
(require (only-in macro-debugger/analysis/check-requires show-requires)
|
|
racket/format
|
|
racket/function
|
|
racket/list
|
|
racket/match
|
|
racket/set)
|
|
|
|
(provide requires/tidy
|
|
requires/trim
|
|
requires/base)
|
|
|
|
(module+ test
|
|
(require rackunit))
|
|
|
|
;; requires/tidy : (listof require-sexpr) -> require-sexpr
|
|
(define (requires/tidy reqs)
|
|
(let* ([reqs (combine-requires reqs)]
|
|
[reqs (group-requires reqs)])
|
|
(require-pretty-format reqs)))
|
|
|
|
;; requires/trim : path-string? (listof require-sexpr) -> require-sexpr
|
|
;;
|
|
;; Note: Why pass in a list of the existing require forms -- why not
|
|
;; just use the "keep" list from show-requires? Because the keep list
|
|
;; only states the module name, not the original form. Therefore if
|
|
;; the original require has a subform like `(only-in mod f)` (or
|
|
;; rename-in, except-in, &c), we won't know how to preserve that
|
|
;; unless we're given it. That's why our strategy must be to look for
|
|
;; things to drop, as opposed to things to keep.
|
|
(define (requires/trim path-str reqs)
|
|
(let* ([reqs (combine-requires reqs)]
|
|
[sr (show-requires* path-str)]
|
|
[drops (filter-map (λ (x)
|
|
(match x
|
|
[(list 'drop mod lvl) (list mod lvl)]
|
|
[_ #f]))
|
|
sr)]
|
|
[reqs (filter-map (λ (req)
|
|
(cond [(member req drops) #f]
|
|
[else req]))
|
|
reqs)]
|
|
[reqs (group-requires reqs)])
|
|
(require-pretty-format reqs)))
|
|
|
|
;; Use `bypass` to help convert from `#lang racket` to `#lang
|
|
;; racket/base` plus explicit requires.
|
|
;;
|
|
;; Note: Currently this is hardcoded to `#lang racket`, only.
|
|
(define (requires/base path-str reqs)
|
|
(let* ([reqs (combine-requires reqs)]
|
|
[sr (show-requires* path-str)]
|
|
[drops (filter-map (λ (x)
|
|
(match x
|
|
[(list 'drop mod lvl) (list mod lvl)]
|
|
[_ #f]))
|
|
sr)]
|
|
[adds (append*
|
|
(filter-map (λ (x)
|
|
(match x
|
|
[(list 'bypass 'racket 0
|
|
(list (list mod lvl _) ...))
|
|
(filter (λ (x)
|
|
(match x
|
|
[(list 'racket/base 0) #f]
|
|
[_ #t]))
|
|
(map list mod lvl))]
|
|
[_ #f]))
|
|
sr))]
|
|
[reqs (filter-map (λ (req)
|
|
(cond [(member req drops) #f]
|
|
[else req]))
|
|
reqs)]
|
|
[reqs (append reqs adds)]
|
|
[reqs (group-requires reqs)])
|
|
(require-pretty-format reqs)))
|
|
|
|
;; show-requires* : Like show-requires but accepts a path-string? that
|
|
;; need not already be a module path.
|
|
(define (show-requires* path-str)
|
|
(define-values (base name _) (split-path (string->path path-str)))
|
|
(parameterize ([current-load-relative-directory base]
|
|
[current-directory base])
|
|
(show-requires name)))
|
|
|
|
(define (combine-requires reqs)
|
|
(remove-duplicates
|
|
(append* (for/list ([req reqs])
|
|
(match req
|
|
[(list* 'require vs)
|
|
(append*
|
|
(for/list ([v vs])
|
|
;; Use (list mod level), like `show-requires` uses.
|
|
(match v
|
|
[(list* 'for-meta level vs) (map (curryr list level) vs)]
|
|
[(list* 'for-syntax vs) (map (curryr list 1) vs)]
|
|
[(list* 'for-template vs) (map (curryr list -1) vs)]
|
|
[(list* 'for-label vs) (map (curryr list #f) vs)]
|
|
[v (list (list v 0))])))])))))
|
|
|
|
(module+ test
|
|
(check-equal?
|
|
(combine-requires '((require a b c)
|
|
(require d e)
|
|
(require a f)
|
|
(require (for-syntax s t u) (for-label l0 l1 l2))
|
|
(require (for-meta 1 m1a m1b)
|
|
(for-meta 2 m2a m2b))))
|
|
'((a 0) (b 0) (c 0) (d 0) (e 0) (f 0)
|
|
(s 1) (t 1) (u 1)
|
|
(l0 #f) (l1 #f) (l2 #f)
|
|
(m1a 1) (m1b 1) (m2a 2) (m2b 2))))
|
|
|
|
;; Given a list of requires -- each in the (list module level) form
|
|
;; used by `show-requires` -- group them by level and convert them to
|
|
;; a Racket `require` form. Also, sort the subforms by phase level:
|
|
;; for-syntax, for-template, for-label, for-meta, and plain (0).
|
|
;; Within each such group, sort them first by module paths then
|
|
;; relative requires. Within each such group, sort alphabetically.
|
|
(define (group-requires reqs)
|
|
;; Put the requires into a hash of sets.
|
|
(define ht (make-hasheq)) ;(hash/c <level> (set <mod>))
|
|
(for ([req reqs]) (match req
|
|
[(list mod lvl) (hash-update! ht lvl
|
|
(lambda (s) (set-add s mod))
|
|
(set mod))]))
|
|
(define (mod-set->mod-list mod-set)
|
|
(sort (set->list mod-set) mod<?))
|
|
(define (for-level level k)
|
|
(define mods (hash-ref ht level #f))
|
|
(cond [mods (k (mod-set->mod-list mods))]
|
|
[else '()]))
|
|
(define (preface . pres)
|
|
(λ (mods) `((,@pres ,@mods))))
|
|
(define (meta-levels)
|
|
(sort (for/list ([x (hash-keys ht)] #:when (not (member x '(-1 0 1 #f)))) x)
|
|
<))
|
|
`(require
|
|
,@(for-level 1 (preface 'for-syntax))
|
|
,@(for-level -1 (preface 'for-template))
|
|
,@(for-level #f (preface 'for-label))
|
|
,@(append* (for/list ([level (in-list (meta-levels))])
|
|
(for-level level (preface 'for-meta level))))
|
|
,@(for-level 0 values)))
|
|
|
|
(module+ test
|
|
(check-equal? (group-requires
|
|
(combine-requires
|
|
'((require z c b a)
|
|
(require (for-meta 4 m41 m40))
|
|
(require (for-meta -4 m-41 m-40))
|
|
(require (for-label l1 l0))
|
|
(require (for-template t1 t0))
|
|
(require (for-syntax s1 s0))
|
|
(require "a.rkt" "b.rkt" "c.rkt" "z.rkt"
|
|
(only-in "mod.rkt" oi)
|
|
(only-in mod oi)))))
|
|
'(require
|
|
(for-syntax s0 s1)
|
|
(for-template t0 t1)
|
|
(for-label l0 l1)
|
|
(for-meta -4 m-40 m-41)
|
|
(for-meta 4 m40 m41)
|
|
a b c (only-in mod oi) z
|
|
"a.rkt" "b.rkt" "c.rkt" (only-in "mod.rkt" oi) "z.rkt")))
|
|
|
|
(define (mod<? a b)
|
|
(define (key x)
|
|
(match x
|
|
[(list 'only-in m _ ...) (key m)]
|
|
[(list 'except-in m _ ...) (key m)]
|
|
[(list 'prefix-in _ m) (key m)]
|
|
[(list 'relative-in _ m _ ...) (key m)]
|
|
[m m]))
|
|
(let ([a (key a)]
|
|
[b (key b)])
|
|
(or (and (symbol? a) (not (symbol? b)))
|
|
(and (list? a) (not (list? b)))
|
|
(and (not (string? a)) (string? a))
|
|
(and (string? a) (string? b)
|
|
(string<? a b))
|
|
(and (symbol? a) (symbol? b)
|
|
(string<? (symbol->string a) (symbol->string b))))))
|
|
|
|
(module+ test
|
|
(check-true (mod<? 'a 'b))
|
|
(check-false (mod<? 'b 'a))
|
|
(check-true (mod<? 'a '(only-in b)))
|
|
(check-true (mod<? '(only-in a) 'b))
|
|
(check-true (mod<? 'a '(except-in b)))
|
|
(check-true (mod<? '(except-in a) 'b))
|
|
(check-true (mod<? 'a '(prefix-in p 'b)))
|
|
(check-true (mod<? '(prefix-in p 'a) 'b))
|
|
(check-true (mod<? 'a '(relative-in p 'b)))
|
|
(check-true (mod<? '(relative-in p 'a) 'b))
|
|
(check-true (mod<? 'a '(prefix-in p (only-in b))))
|
|
(check-true (mod<? '(prefix-in p (only-in a)) 'b)))
|
|
|
|
;; require-pretty-format : list? -> string?
|
|
(define (require-pretty-format x)
|
|
(define out (open-output-string))
|
|
(parameterize ([current-output-port out])
|
|
(require-pretty-print x))
|
|
(get-output-string out))
|
|
|
|
(module+ test
|
|
(check-equal? (require-pretty-format
|
|
'(require a))
|
|
@~a{(require a)
|
|
|
|
})
|
|
(check-equal? (require-pretty-format
|
|
'(require a b))
|
|
@~a{(require a
|
|
b)
|
|
|
|
})
|
|
(check-equal? (require-pretty-format
|
|
'(require (for-syntax a b) (for-meta 2 c d) e f))
|
|
@~a{(require (for-syntax a
|
|
b)
|
|
(for-meta 2 c
|
|
d)
|
|
e
|
|
f)
|
|
|
|
})
|
|
(check-equal? (require-pretty-format
|
|
`(require (only-in m a b) (except-in m a b)))
|
|
@~a{(require (only-in m
|
|
a
|
|
b)
|
|
(except-in m
|
|
a
|
|
b))
|
|
|
|
}))
|
|
|
|
;; Pretty print a require form with one module per line and with
|
|
;; indentation for the `for-X` subforms. Example:
|
|
;;
|
|
;; (require (for-syntax racket/base
|
|
;; syntax/parse)
|
|
;; (for-meta 3 racket/a
|
|
;; racket/b)
|
|
;; racket/format
|
|
;; racket/string
|
|
;; "a.rkt"
|
|
;; "b.rkt")
|
|
(define (require-pretty-print x)
|
|
(define (prn x first? indent)
|
|
(define (indent-string)
|
|
(if first? "" (make-string indent #\space)))
|
|
(define (prn-form pre this more)
|
|
(define new-indent (+ indent (+ 2 (string-length pre))))
|
|
(printf "~a(~a " (indent-string) pre)
|
|
(prn this #t new-indent)
|
|
(for ([x more])
|
|
(newline)
|
|
(prn x #f new-indent))
|
|
(display ")"))
|
|
(match x
|
|
[(list 'require)
|
|
(void)]
|
|
[(list* (and pre (or 'require 'for-syntax 'for-template 'for-label
|
|
'only-in 'except-in))
|
|
this more)
|
|
(prn-form (format "~s" pre) this more)
|
|
(when (eq? pre 'require)
|
|
(newline))]
|
|
[(list* 'for-meta level this more)
|
|
(prn-form (format "for-meta ~a" level) this more)]
|
|
[this
|
|
(printf "~a~s" (indent-string) this)]))
|
|
(prn x #t 0))
|