561 lines
25 KiB
Racket
561 lines
25 KiB
Racket
#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))]))
|
|
|#
|