Remove drracket/private/module-interface.
With permission from Jon Rafkind.
This commit is contained in:
Asumu Takikawa
parent
f34258e253
commit
a00cd7ebff
|
|
@ -1,560 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
#|
|
|
||||||
Show imports (symbols that come from requires) and exports (symbols that are provided)
|
|
||||||
|
|
||||||
1. How can I avoid showing imported symbols from the lang line? It would be nice to
|
|
||||||
ignore all the symbols from racket/base if a file starts with
|
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
|#
|
|
||||||
|
|
||||||
(require racket/match
|
|
||||||
unstable/generics
|
|
||||||
racket/pretty
|
|
||||||
syntax/parse
|
|
||||||
(for-syntax racket/struct-info
|
|
||||||
racket/base
|
|
||||||
syntax/parse
|
|
||||||
racket/match))
|
|
||||||
|
|
||||||
(provide get-exports
|
|
||||||
(struct-out provided))
|
|
||||||
|
|
||||||
(define module-name
|
|
||||||
(compose resolved-module-path-name module-path-index-resolve))
|
|
||||||
|
|
||||||
(define-syntax (import-struct stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ ([struct-name:identifier instance:identifier] more ...) body ...)
|
|
||||||
(define (get-fields struct instance)
|
|
||||||
;; (printf "Import struct for ~a\n" #'struct-name)
|
|
||||||
(let ([info (syntax-local-value struct (lambda () #f))])
|
|
||||||
(match (extract-struct-info info)
|
|
||||||
[(list name init-field-count auto-field-count accessor-proc
|
|
||||||
mutator-proc immutable-k-list)
|
|
||||||
(begin
|
|
||||||
;; messing around with strings is bad, whats a better solution?
|
|
||||||
(define (make-local-field field-stx)
|
|
||||||
(let* ([field (substring (symbol->string (syntax->datum field-stx))
|
|
||||||
(- (string-length (string-append (symbol->string (syntax->datum name)) "-"))
|
|
||||||
(string-length "struct:")))]
|
|
||||||
[final (string->symbol (string-append (symbol->string
|
|
||||||
(syntax->datum instance))
|
|
||||||
"."
|
|
||||||
field))])
|
|
||||||
(datum->syntax instance final instance instance)))
|
|
||||||
#;
|
|
||||||
(apply printf "name: ~a init-field-count: ~a auto-field-count: ~a accessor-proc: ~a mutator-proc: ~a immutable-k-list: ~a\n"
|
|
||||||
(list name init-field-count auto-field-count (map syntax->datum accessor-proc)
|
|
||||||
mutator-proc immutable-k-list))
|
|
||||||
(with-syntax ([(field ...)
|
|
||||||
(map make-local-field accessor-proc)]
|
|
||||||
[(setter! ...) mutator-proc]
|
|
||||||
[instance instance]
|
|
||||||
[(accessor ...) accessor-proc])
|
|
||||||
#|
|
|
||||||
(printf "bind: ~a\n" (map syntax->datum (syntax->list #'(field ...))))
|
|
||||||
(printf "setter: ~a\n" (map syntax->datum (syntax->list #'(setter! ...))))
|
|
||||||
|#
|
|
||||||
(begin
|
|
||||||
#;syntax-local-introduce
|
|
||||||
#;
|
|
||||||
#'(let ([my-accessor])
|
|
||||||
let-syntax ([field (make-rename-transformer my-accessor)] ...)
|
|
||||||
body)
|
|
||||||
|
|
||||||
#;
|
|
||||||
#'(let ([field (make-rename-transformer #'field
|
|
||||||
(accessor instance))]
|
|
||||||
...)
|
|
||||||
body)
|
|
||||||
|
|
||||||
#'([field (make-set!-transformer
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx (set!)
|
|
||||||
[(set! id v) (if #'setter!
|
|
||||||
#'(setter! instance v)
|
|
||||||
#'(error 'with-struct "field ~a is not mutable so no set! is available" 'field))]
|
|
||||||
[id #'(accessor instance)])))]
|
|
||||||
...)
|
|
||||||
|
|
||||||
#;
|
|
||||||
#'(let-syntax ([field (make-set!-transformer
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx (set!)
|
|
||||||
[(set! id v) (if #'setter!
|
|
||||||
#'(setter! instance v)
|
|
||||||
#'(error 'with-struct "field ~a is not mutable so no set! is available" 'field))]
|
|
||||||
[id #'(accessor instance)])))]
|
|
||||||
...)
|
|
||||||
body ...)
|
|
||||||
|
|
||||||
#;
|
|
||||||
#'(let-syntax ([field (lambda (stx)
|
|
||||||
#'(accessor instance))]
|
|
||||||
...)
|
|
||||||
body1 body ...))))])))
|
|
||||||
(with-syntax ([(field ...) (get-fields #'struct-name #'instance)])
|
|
||||||
;; (printf "Final let syntax is ~a\n" (syntax->datum #'(let-syntax (field ...) body ...)))
|
|
||||||
#'(let-syntax (field ...)
|
|
||||||
(import-struct (more ...) body ...)))]
|
|
||||||
[(_ () body ...)
|
|
||||||
#'(begin body ...)]))
|
|
||||||
|
|
||||||
(generics module-symbol
|
|
||||||
(print module-symbol)
|
|
||||||
(get-symbol module-symbol))
|
|
||||||
|
|
||||||
(provide print)
|
|
||||||
|
|
||||||
(define-syntax-rule (define-module-symbol name (fields ...) rest ...)
|
|
||||||
(define-struct name (fields ...)
|
|
||||||
#:property prop:module-symbol
|
|
||||||
rest ...))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:normal (name)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define (get-symbol self) (symbol:normal-name self))
|
|
||||||
(define (print self)
|
|
||||||
(import-struct ([symbol:normal self])
|
|
||||||
(format "~a" self.name)))))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:normal/contract (name contract)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define (get-symbol self) (symbol:normal-name self))
|
|
||||||
(define (print self)
|
|
||||||
(import-struct ([symbol:normal/contract self])
|
|
||||||
(format "~a contract ~a" self.name self.contract)))))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:renamed (provided defined)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define (get-symbol self) (symbol:renamed-provided self))
|
|
||||||
(define (print self)
|
|
||||||
(import-struct ([symbol:renamed self])
|
|
||||||
(format "~a as ~a" self.defined self.provided)))))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:module-exported (where)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define/generic symbol-print print)
|
|
||||||
(define (get-symbol self)
|
|
||||||
(raise 'get-symbol "Not defined"))
|
|
||||||
(define (print self)
|
|
||||||
(format "from ~a"
|
|
||||||
(module-name
|
|
||||||
(symbol:module-exported-where self))
|
|
||||||
))))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:module-exported-from (original where)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define/generic symbol-print print)
|
|
||||||
(define (get-symbol self)
|
|
||||||
(raise 'get-symbol "Not defined"))
|
|
||||||
(define (print self)
|
|
||||||
(import-struct ([symbol:module-exported-from self])
|
|
||||||
(format "from ~a ~a"
|
|
||||||
(module-name self.where)
|
|
||||||
(symbol-print self.original))))))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:module-exported-as
|
|
||||||
(where phase-shift imported-name import-shift)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define/generic symbol-print print)
|
|
||||||
(define (get-symbol self)
|
|
||||||
(symbol:module-exported-as-imported-name self))
|
|
||||||
(define (print self)
|
|
||||||
(import-struct ([symbol:module-exported-as self])
|
|
||||||
(format "from ~a as ~a"
|
|
||||||
(module-name self.where)
|
|
||||||
self.imported-name)))))
|
|
||||||
|
|
||||||
(define-module-symbol symbol:multiple-modules (symbol modules)
|
|
||||||
(define-methods module-symbol
|
|
||||||
(define/generic symbol-print print)
|
|
||||||
(define/generic symbol-get-symbol get-symbol)
|
|
||||||
(define (get-symbol self)
|
|
||||||
(symbol-get-symbol
|
|
||||||
(symbol:multiple-modules-symbol self)))
|
|
||||||
(define (print self)
|
|
||||||
(import-struct ([symbol:multiple-modules self])
|
|
||||||
(format "~a ~a"
|
|
||||||
(symbol-print self.symbol)
|
|
||||||
(let ([modules self.modules])
|
|
||||||
(if (null? modules)
|
|
||||||
""
|
|
||||||
(for/fold ([start (symbol-print (car modules))])
|
|
||||||
([next (cdr modules)])
|
|
||||||
(format "~a and ~a" start (symbol-print next))))))))))
|
|
||||||
|
|
||||||
(struct provided (phase variables syntaxes))
|
|
||||||
|
|
||||||
(define get-namespace
|
|
||||||
(let ([namespaces (make-hash)])
|
|
||||||
(lambda (file)
|
|
||||||
(hash-ref namespaces file (lambda ()
|
|
||||||
(let ([new (make-base-namespace)])
|
|
||||||
(hash-set! namespaces file new)
|
|
||||||
new))))))
|
|
||||||
|
|
||||||
(define (read-file file)
|
|
||||||
(parameterize ([read-accept-reader #t])
|
|
||||||
(with-input-from-file file (lambda () (read)))))
|
|
||||||
|
|
||||||
;; extract the symbol from the module and call `contract-name' on its contract
|
|
||||||
(define (get-contract symbol file)
|
|
||||||
(parameterize ([current-namespace
|
|
||||||
(get-namespace file)
|
|
||||||
#;
|
|
||||||
(make-base-namespace)])
|
|
||||||
;; FIXME! it would be nice if we could pull multiple symbols out
|
|
||||||
;; in the same `dynamic-require' call
|
|
||||||
(define has-contract? (dynamic-require 'racket/contract 'has-contract?))
|
|
||||||
(define value-contract (dynamic-require 'racket/contract 'value-contract))
|
|
||||||
(define contract-name (dynamic-require 'racket/contract 'contract-name))
|
|
||||||
;; syntax expansion might fail, just ignore it
|
|
||||||
(with-handlers ([exn:fail:syntax? (lambda (e) #f)])
|
|
||||||
(let ([result (dynamic-require file symbol (lambda () #f))])
|
|
||||||
#;
|
|
||||||
(printf "Result is ~a\n" result)
|
|
||||||
#;
|
|
||||||
(printf "v is ~a\n" v)
|
|
||||||
#;
|
|
||||||
(printf "v has contract? ~a\n" (has-contract? v))
|
|
||||||
(if (has-contract? result)
|
|
||||||
(contract-name (value-contract result))
|
|
||||||
#f)))))
|
|
||||||
|
|
||||||
(define (make-symbol something file get-contract?)
|
|
||||||
(define (populate-symbol symbol)
|
|
||||||
(if (not get-contract?)
|
|
||||||
(symbol:normal symbol)
|
|
||||||
(let ([contract (get-contract symbol file)])
|
|
||||||
(if contract
|
|
||||||
(symbol:normal/contract symbol contract)
|
|
||||||
(symbol:normal symbol)))))
|
|
||||||
(define (extract-module path)
|
|
||||||
(match path
|
|
||||||
[(and (? module-path-index?) module)
|
|
||||||
(symbol:module-exported module)]
|
|
||||||
[(list path phase-shift imported-name imported-phase)
|
|
||||||
(symbol:module-exported-as path
|
|
||||||
phase-shift
|
|
||||||
imported-name
|
|
||||||
imported-phase)]))
|
|
||||||
(match something
|
|
||||||
[(list exported (list paths ...))
|
|
||||||
(symbol:multiple-modules (populate-symbol exported)
|
|
||||||
(map extract-module paths))]))
|
|
||||||
|
|
||||||
(define (extract-base-module module-code)
|
|
||||||
(syntax-parse module-code
|
|
||||||
[(module name base . rest) (syntax->datum #'base)]))
|
|
||||||
|
|
||||||
(define (module=? module1 module2)
|
|
||||||
(define (resolve module)
|
|
||||||
(cond
|
|
||||||
[(symbol? module) (module-path-index-resolve (module-path-index-join module #f))]
|
|
||||||
[(resolved-module-path? module) module]
|
|
||||||
;; [(module-path-index? module) (
|
|
||||||
[(module-path-index? module)
|
|
||||||
(module-path-index-resolve module)
|
|
||||||
#;
|
|
||||||
(let-values ([(path base) (module-path-index-split module)])
|
|
||||||
(printf "Split module path ~a base ~a\n" path base)
|
|
||||||
((current-module-name-resolver) path))]
|
|
||||||
[else (error 'module=? "Dont understand ~a" module)]))
|
|
||||||
(define (raw-exports module)
|
|
||||||
(parameterize ([current-namespace
|
|
||||||
(get-namespace (resolved-module-path-name module))
|
|
||||||
#;
|
|
||||||
(make-base-namespace)])
|
|
||||||
(dynamic-require (resolved-module-path-name module) #f)
|
|
||||||
(call-with-values (lambda () (module->exports (resolved-module-path-name module)))
|
|
||||||
(lambda v v))))
|
|
||||||
#;
|
|
||||||
(printf "~a resolved ~a. ~a resolved ~a\n" module1 (resolve module1)
|
|
||||||
module2 (resolve module2))
|
|
||||||
(eq? (resolve module1) (resolve module2))
|
|
||||||
#;
|
|
||||||
(equal? (raw-exports (resolve module1))
|
|
||||||
(raw-exports (resolve module2)))
|
|
||||||
#;
|
|
||||||
(equal? (resolve module1) (resolve module2)))
|
|
||||||
|
|
||||||
(define (get-imports file all?)
|
|
||||||
(let ([imports (parameterize ([current-namespace
|
|
||||||
(get-namespace file)
|
|
||||||
#;
|
|
||||||
(make-base-namespace)])
|
|
||||||
(dynamic-require file #f)
|
|
||||||
(module->imports file))])
|
|
||||||
(define (combine-provides provides)
|
|
||||||
;; provides is guaranteed to have at least one thing or we wouldn't get here
|
|
||||||
(for/fold ([all (car provides)])
|
|
||||||
([provide (cdr provides)])
|
|
||||||
(provided (provided-phase all)
|
|
||||||
(append (provided-variables all)
|
|
||||||
(provided-variables provide))
|
|
||||||
(append (provided-syntaxes all)
|
|
||||||
(provided-syntaxes provide)))))
|
|
||||||
(define phase-imports (make-hash))
|
|
||||||
(define base-module (extract-base-module (read-file file)))
|
|
||||||
(define (fixup-paths path exports)
|
|
||||||
(for/list ([export exports])
|
|
||||||
(match export
|
|
||||||
[(symbol:multiple-modules symbol modules)
|
|
||||||
(symbol:multiple-modules symbol
|
|
||||||
(if (null? modules)
|
|
||||||
(list (symbol:module-exported path))
|
|
||||||
(map (lambda (module)
|
|
||||||
(symbol:module-exported-from
|
|
||||||
module path))
|
|
||||||
modules)))])))
|
|
||||||
(define (add-provide phase provide)
|
|
||||||
(hash-set! phase-imports
|
|
||||||
phase
|
|
||||||
(cons provide (hash-ref phase-imports phase (lambda () (list))))))
|
|
||||||
;; (printf "Base module is ~a ~a\n" base-module (make-resolved-module-path base-module))
|
|
||||||
(for ([import imports])
|
|
||||||
(match import
|
|
||||||
[(list phase-shift paths ...)
|
|
||||||
;; (printf "Import at phase shift ~a\n" phase-shift)
|
|
||||||
(for ([path paths])
|
|
||||||
;; (printf " Module ~a\n" (module-name path))
|
|
||||||
(define module-path (let-values ([(module-path rest) (module-path-index-split path)])
|
|
||||||
;; (printf "Module path is ~a. Rest is ~a\n" module-path rest)
|
|
||||||
module-path))
|
|
||||||
; (define resolved-module-path (module-path-index-resolve path))
|
|
||||||
;; (define resolved-module-path (make-resolved-module-path module-path))
|
|
||||||
;; (printf "base ~a = resolved ~a is ~a\n" base-module path (module=? base-module path))
|
|
||||||
(when (or all? (not (module=? path base-module)))
|
|
||||||
(let ([exports (get-exports module-path #f)])
|
|
||||||
(for ([export exports])
|
|
||||||
(match export
|
|
||||||
[(provided phase variables syntaxes)
|
|
||||||
(add-provide (+ phase phase-shift)
|
|
||||||
(provided (+ phase phase-shift)
|
|
||||||
(fixup-paths path variables)
|
|
||||||
(fixup-paths path syntaxes)))])))))]))
|
|
||||||
(hash-map phase-imports (lambda (phase provides)
|
|
||||||
(combine-provides provides)))))
|
|
||||||
|
|
||||||
(define (get-exports file get-contracts?)
|
|
||||||
(define (sort-symbols symbols)
|
|
||||||
(sort symbols (lambda (a b)
|
|
||||||
(define (get-symbol what)
|
|
||||||
(match what
|
|
||||||
[(list name rest ...) (symbol->string name)]))
|
|
||||||
(string<? (get-symbol a)
|
|
||||||
(get-symbol b)))))
|
|
||||||
(define (make-symbol* export)
|
|
||||||
(make-symbol export file get-contracts?))
|
|
||||||
(let-values ([(exported-variables
|
|
||||||
exported-syntaxes)
|
|
||||||
(parameterize ([current-namespace
|
|
||||||
(get-namespace file)
|
|
||||||
#;
|
|
||||||
(make-base-namespace)])
|
|
||||||
(dynamic-require file #f)
|
|
||||||
(module->exports file))])
|
|
||||||
#;
|
|
||||||
(pretty-print (syntax->datum
|
|
||||||
(parameterize ([current-namespace (make-base-namespace)])
|
|
||||||
(expand (read-file file)))))
|
|
||||||
|
|
||||||
|
|
||||||
; (printf "Expanded is ~a\n" expanded)
|
|
||||||
; (printf "Variables ~a\n" (syntax-property expanded 'module-variable-provides))
|
|
||||||
; (printf "Syntaxes ~a\n" (syntax-property expanded 'module-syntax-provides))
|
|
||||||
(define exports (make-hash))
|
|
||||||
(for ([export exported-variables])
|
|
||||||
(match export
|
|
||||||
[(list (and (? number?) phase) symbols ...)
|
|
||||||
(hash-set! exports phase (provided phase
|
|
||||||
(map make-symbol* (sort-symbols symbols))
|
|
||||||
'()))]))
|
|
||||||
(for ([export exported-syntaxes])
|
|
||||||
(match export
|
|
||||||
[(list (and (? number?) phase) symbols ...)
|
|
||||||
(hash-set! exports phase
|
|
||||||
(let ([existing (hash-ref exports phase (lambda () (provided phase '() '())))])
|
|
||||||
(provided phase
|
|
||||||
(provided-variables existing)
|
|
||||||
(map make-symbol* (sort-symbols symbols)))))]))
|
|
||||||
(hash-map exports (lambda (a b) b))))
|
|
||||||
|
|
||||||
|
|
||||||
(define (phase-name phase)
|
|
||||||
(case phase
|
|
||||||
[(0) " (runtime)"]
|
|
||||||
[(1) " (syntax)"]
|
|
||||||
[(-1) " (template)"]
|
|
||||||
[else ""]))
|
|
||||||
|
|
||||||
#|
|
|
||||||
(define (find-file provides category search)
|
|
||||||
(struct levenshtein (name distance phase))
|
|
||||||
;; find the levenshtein distance between the searched-for term and the name
|
|
||||||
(define (fuzzy-search search name)
|
|
||||||
(local-require (prefix-in neil: (planet neil/levenshtein:1:3/levenshtein)))
|
|
||||||
;; (printf "Name is ~a\n" name)
|
|
||||||
(define real-name (symbol->string (get-symbol name)))
|
|
||||||
(let ([search-in real-name])
|
|
||||||
(define distance (neil:string-levenshtein search search-in))
|
|
||||||
(levenshtein real-name distance 0)))
|
|
||||||
|
|
||||||
(define (compare-levenshtein object1 object2)
|
|
||||||
(< (levenshtein-distance object1)
|
|
||||||
(levenshtein-distance object2)))
|
|
||||||
(define (do-search export)
|
|
||||||
(match export
|
|
||||||
[(provided phase variables syntaxes)
|
|
||||||
;; replace the phase from the fuzzy-search with the phase from the export
|
|
||||||
(define (update-phase stuff)
|
|
||||||
(for/list ([object stuff])
|
|
||||||
(match object
|
|
||||||
[(levenshtein name distance dont-care)
|
|
||||||
(levenshtein name distance phase)])))
|
|
||||||
(let ([found-variables (map (lambda (variable)
|
|
||||||
(fuzzy-search search variable))
|
|
||||||
variables)]
|
|
||||||
[found-syntaxes (map (lambda (syntax)
|
|
||||||
(fuzzy-search search syntax))
|
|
||||||
syntaxes)])
|
|
||||||
(append (update-phase found-variables)
|
|
||||||
(update-phase found-syntaxes)))]))
|
|
||||||
(let* ([exports provides]
|
|
||||||
[found (apply append (map do-search exports))]
|
|
||||||
[sorted (sort found compare-levenshtein)])
|
|
||||||
(if (null? sorted)
|
|
||||||
(printf "No ~as available\n" category)
|
|
||||||
(for ([i (in-range 1 6)]
|
|
||||||
[found sorted])
|
|
||||||
(match found
|
|
||||||
[(levenshtein name distance phase)
|
|
||||||
(printf "~a. Found ~a `~a' at phase ~a\n" i category name phase)])))))
|
|
||||||
|
|
||||||
(define (find-file-export file search)
|
|
||||||
(find-file (get-exports file #f) "export" search))
|
|
||||||
|
|
||||||
(define (find-file-import file search)
|
|
||||||
(find-file (get-imports file #t) "import" search))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(define (find-defines file)
|
|
||||||
(define defines
|
|
||||||
(parameterize ([current-load-relative-directory (let-values ([(care a b)
|
|
||||||
(split-path (path->complete-path (resolve-path (string->path file))))])
|
|
||||||
care)])
|
|
||||||
(let ([code (parameterize ([current-namespace (make-base-namespace)])
|
|
||||||
(expand (read-file file)))])
|
|
||||||
(syntax-case code (module)
|
|
||||||
[(module name base (module-begin stuff ...))
|
|
||||||
(apply append
|
|
||||||
(for/list ([top-level (syntax->list #'(stuff ...))])
|
|
||||||
(syntax-case top-level (define-values define-syntaxes)
|
|
||||||
[(define-values (name ...) . body)
|
|
||||||
(for/list ([name (syntax->list #'(name ...))])
|
|
||||||
(symbol->string (syntax->datum name))
|
|
||||||
#;
|
|
||||||
(printf "~a\n" (syntax->datum name)))]
|
|
||||||
[(define-syntaxes (name ...) . body)
|
|
||||||
(for/list ([name (syntax->list #'(name ...))])
|
|
||||||
(symbol->string (syntax->datum name))
|
|
||||||
#;
|
|
||||||
(printf "~a\n" (syntax->datum name)))]
|
|
||||||
[else (list)])))]))))
|
|
||||||
(for ([item (sort defines string<?)])
|
|
||||||
(printf "~a\n" item)))
|
|
||||||
|
|
||||||
(define (check-file/raw file phase show-imports? show-exports?)
|
|
||||||
(define (print-all stuff)
|
|
||||||
(for ([symbol stuff])
|
|
||||||
(printf "~a\n" (print symbol))))
|
|
||||||
(define (show-all provides)
|
|
||||||
(for ([provide provides])
|
|
||||||
(when (or (eq? phase 'all)
|
|
||||||
(equal? phase (provided-phase provide)))
|
|
||||||
(print-all (provided-variables provide))
|
|
||||||
(print-all (provided-syntaxes provide)))))
|
|
||||||
|
|
||||||
(define (show-imports)
|
|
||||||
(show-all (get-imports file #f)))
|
|
||||||
(define (show-exports)
|
|
||||||
(show-all (get-exports file #f)))
|
|
||||||
(when show-imports?
|
|
||||||
(show-imports))
|
|
||||||
(when show-exports?
|
|
||||||
(show-exports)))
|
|
||||||
|
|
||||||
(define (check-file file phase show-imports? show-exports?)
|
|
||||||
(define (print-all prefix stuff)
|
|
||||||
(for ([symbol stuff])
|
|
||||||
(printf "~a~a\n" prefix (print symbol))))
|
|
||||||
(define (show-all what provides)
|
|
||||||
(define (space n)
|
|
||||||
(make-string n #\space))
|
|
||||||
(printf "~a\n" what)
|
|
||||||
(for ([provide provides])
|
|
||||||
(when (or (eq? phase 'all)
|
|
||||||
(equal? phase (provided-phase provide)))
|
|
||||||
(printf " Phase ~a~a\n" (provided-phase provide)
|
|
||||||
(phase-name (provided-phase provide)))
|
|
||||||
(printf " Variables\n")
|
|
||||||
(print-all (space 6) (provided-variables provide))
|
|
||||||
(printf " Syntaxes\n")
|
|
||||||
(print-all (space 6) (provided-syntaxes provide)))))
|
|
||||||
(define (show-imports)
|
|
||||||
(show-all "Imports" (get-imports file #f)))
|
|
||||||
(define (show-exports)
|
|
||||||
(show-all "Exports" (get-exports file #t)))
|
|
||||||
(when show-imports?
|
|
||||||
(show-imports)
|
|
||||||
(printf "\n"))
|
|
||||||
(when show-exports?
|
|
||||||
(show-exports)))
|
|
||||||
|
|
||||||
#|
|
|
||||||
(define mode (make-parameter 'show))
|
|
||||||
(define only-phase (make-parameter 'all))
|
|
||||||
(define show-imports (make-parameter #t))
|
|
||||||
(define show-exports (make-parameter #t))
|
|
||||||
(define find-export (make-parameter #f))
|
|
||||||
(define find-import (make-parameter #f))
|
|
||||||
|
|
||||||
(define (do-parse-command-line)
|
|
||||||
(local-require racket/cmdline)
|
|
||||||
(command-line
|
|
||||||
#:program "checker"
|
|
||||||
#:once-each
|
|
||||||
[("--raw") "Just print a list of identifiers without any formatting"
|
|
||||||
(mode 'raw)]
|
|
||||||
[("--phase") phase
|
|
||||||
"Only show identifiers at this phase"
|
|
||||||
(only-phase (string->number phase))]
|
|
||||||
[("--exports") "Only show exports"
|
|
||||||
(show-imports #f)]
|
|
||||||
[("--imports") "Only show imports"
|
|
||||||
(show-exports #f)]
|
|
||||||
[("--defines") "Only show defined identifiers"
|
|
||||||
(mode 'defines)]
|
|
||||||
[("--find-export") export "Do a fuzzy match for an export"
|
|
||||||
(begin
|
|
||||||
(mode 'find-export)
|
|
||||||
(find-export export))]
|
|
||||||
[("--find-import") import "Do a fuzzy match for an import"
|
|
||||||
(begin
|
|
||||||
(mode 'find-import)
|
|
||||||
(find-import import))]
|
|
||||||
#:args files
|
|
||||||
files))
|
|
||||||
|
|
||||||
(for ([file (do-parse-command-line)])
|
|
||||||
(printf "Checking file ~a\n" file)
|
|
||||||
(case (mode)
|
|
||||||
[(show) (check-file (string->path file) (only-phase) (show-imports) (show-exports))]
|
|
||||||
[(raw) (check-file/raw (string->path file) (only-phase) (show-imports) (show-exports))]
|
|
||||||
[(defines) (find-defines file)]
|
|
||||||
[(find-export) (find-file-export file (find-export))]
|
|
||||||
[(find-import) (find-file-import file (find-import))]))
|
|
||||||
|#
|
|
||||||
|
|
@ -1,52 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
;; Shows a gui of provided identifiers with some extra information such as
|
|
||||||
;; contracts (works)
|
|
||||||
;; typed racket types (doesn't work)
|
|
||||||
|
|
||||||
(require (prefix-in check: "check.rkt")
|
|
||||||
framework/framework
|
|
||||||
racket/gui/base
|
|
||||||
racket/class)
|
|
||||||
|
|
||||||
(provide build-gui)
|
|
||||||
|
|
||||||
(define (build-gui gui-parent file)
|
|
||||||
(define exports (check:get-exports file #true))
|
|
||||||
(for ([provide (map check:provided-syntaxes exports)])
|
|
||||||
(printf "syntaxes exports (~a): ~a\n" (length provide) (map check:print provide)))
|
|
||||||
|
|
||||||
(for ([provide (map check:provided-variables exports)])
|
|
||||||
(printf "variables (~a): ~a\n" (length provide) (map check:print provide)))
|
|
||||||
|
|
||||||
#;
|
|
||||||
(printf "exports: ~a\n" (map check:print
|
|
||||||
(map check:provided-syntaxes
|
|
||||||
(check:get-exports "x.rkt" #true))))
|
|
||||||
|
|
||||||
(define stuff (new vertical-pane% [parent gui-parent]))
|
|
||||||
(new message% [parent stuff] [label "Contracts"])
|
|
||||||
(define contract-pane (new horizontal-panel% [parent stuff]))
|
|
||||||
(define contract-text (new racket:text%))
|
|
||||||
(define contract-editor (new editor-canvas% [parent contract-pane] [editor contract-text]))
|
|
||||||
(new message% [parent stuff] [label "No contracts"])
|
|
||||||
(define non-contract-pane (new horizontal-panel% [parent stuff]))
|
|
||||||
(define non-contract-text (new racket:text%))
|
|
||||||
(define non-contract-editor (new editor-canvas% [parent non-contract-pane] [editor non-contract-text]))
|
|
||||||
(for ([provide/phase (map check:provided-syntaxes exports)])
|
|
||||||
(for ([symbol provide/phase])
|
|
||||||
(send contract-text insert (check:print symbol))
|
|
||||||
(send contract-text insert "\n")
|
|
||||||
))
|
|
||||||
(for ([provide/phase (map check:provided-variables exports)])
|
|
||||||
(for ([symbol provide/phase])
|
|
||||||
(send non-contract-text insert (check:print symbol))
|
|
||||||
(send non-contract-text insert "\n")
|
|
||||||
))
|
|
||||||
)
|
|
||||||
|
|
||||||
#|
|
|
||||||
(let ([frame (new frame:basic% [label ""] [width 500] [height 500])])
|
|
||||||
(build-gui (send frame get-area-container))
|
|
||||||
(send frame show #true))
|
|
||||||
|#
|
|
||||||
Loading…
Reference in New Issue
Block a user