From a00cd7ebffb1279e6cb07175866335cc2702319d Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 18 May 2012 15:50:32 -0400
Subject: [PATCH] Remove drracket/private/module-interface.

With permission from Jon Rafkind.
---
 .../private/module-interface/check.rkt        | 560 ------------------
 .../drracket/private/module-interface/gui.rkt |  52 --
 2 files changed, 612 deletions(-)
 delete mode 100644 collects/drracket/private/module-interface/check.rkt
 delete mode 100644 collects/drracket/private/module-interface/gui.rkt

diff --git a/collects/drracket/private/module-interface/check.rkt b/collects/drracket/private/module-interface/check.rkt
deleted file mode 100644
index 30aea7bc94..0000000000
--- a/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))]))
-|#
diff --git a/collects/drracket/private/module-interface/gui.rkt b/collects/drracket/private/module-interface/gui.rkt
deleted file mode 100644
index 323d7ab4df..0000000000
--- a/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))
-|#