[racket-dev] [plt] Push #24721: master branch updated
Was this an attempt to show the interfaces of a module? I do wish we had one inside of DrRacket.
On May 18, 2012, at 4:05 PM, asumu at racket-lang.org wrote:
> asumu has updated `master' from f34258e253 to a00cd7ebff.
> http://git.racket-lang.org/plt/f34258e253..a00cd7ebff
>
> =====[ 1 Commits ]======================================================
>
> Directory summary:
> 100.0% collects/drracket/private/module-interface/
>
> ~~~~~~~~~~
>
> a00cd7e Asumu Takikawa <asumu at racket-lang.org> 2012-05-18 15:50
> :
> | Remove drracket/private/module-interface.
> |
> | With permission from Jon Rafkind.
> :
> D collects/drracket/private/module-interface/check.rkt
> D collects/drracket/private/module-interface/gui.rkt
>
> =====[ Overall Diff ]===================================================
>
> collects/drracket/private/module-interface/check.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/drracket/private/module-interface/check.rkt
> +++ /dev/null
> @@ -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))]))
> -|#
>
> collects/drracket/private/module-interface/gui.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/drracket/private/module-interface/gui.rkt
> +++ /dev/null
> @@ -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))
> -|#
![[logo]](/logo.png){kind=logo}