
(module module-overview mzscheme
  (require (lib "mred.ss" "mred")
           (lib "class.ss")
	   (lib "list.ss")
           (lib "string.ss")
           (lib "moddep.ss" "syntax")
           (lib "toplevel.ss" "syntax")
           (lib "framework.ss" "framework")
           (lib "string-constant.ss" "string-constants")
           (lib "graph.ss" "mrlib")
           "drsig.ss"
           (lib "unitsig.ss")
           (lib "unit.ss")
           (lib "async-channel.ss"))
  
  (provide module-overview@)
  (define module-overview@
    (unit/sig drscheme:module-overview^
      (import [drscheme:frame : drscheme:frame^]
              [drscheme:eval : drscheme:eval^]
              [drscheme:language-configuration : drscheme:language-configuration/internal^]
              [drscheme:language : drscheme:language^])
      
      (define filename-constant (string-constant module-browser-filename-format))
      (define font-size-gauge-label (string-constant module-browser-font-size-gauge-label))
      (define progress-label (string-constant module-browser-progress-label))
      (define adding-file (string-constant module-browser-adding-file))
      (define laying-out-graph-label (string-constant module-browser-laying-out-graph-label))
      (define open-file-format (string-constant module-browser-open-file-format))
      (define lib-paths-checkbox-constant (string-constant module-browser-show-lib-paths))
      
      (define unknown-module-name "? unknown module name")
      
      (preferences:set-default 'drscheme:module-overview:label-font-size 12 number?)
      (preferences:set-default 'drscheme:module-overview:window-height 500 number?)
      (preferences:set-default 'drscheme:module-overview:window-width 500 number?)
      (preferences:set-default 'drscheme:module-browser:show-lib-paths? #f boolean?)
      
      (define (set-box/f b v) (when (box? b) (set-box! b v)))
      
      (define (module-overview parent)
        (let ([filename (get-file #f parent)])
          (when filename
            (module-overview/file filename parent))))

      (define (find-label-font size)
        (send the-font-list find-or-create-font size 'decorative 'normal 'normal #f))
      
      (define module-overview-pasteboard<%>
        (interface ()
          set-label-font-size
          get-label-font-size
          show-lib-paths
          set-name-length
          get-name-length))
      
      (define boxed-word-snip<%>
        (interface ()
          get-filename
          get-word
          get-lines
          get-lib-children
          add-lib-child))
      
      (define-struct req (filename lib?))
      ;; type req = (make-req string[filename] boolean)
      
      ;; make-module-overview-pasteboard : boolean
      ;;                                   ((union #f snip) -> void)
      ;;                                -> (union string pasteboard)
      ;; string as result indicates an error message
      ;; pasteboard as result is the pasteboard to show
      (define (make-module-overview-pasteboard vertical? mouse-currently-over)
        
        (define level-ht (make-hash-table))

        ;; snip-table : hash-table[sym -o> snip]
        (define snip-table (make-hash-table 'equal))
        (define label-font (find-label-font (preferences:get 'drscheme:module-overview:label-font-size)))
        (define text-color (make-object color% "blue"))
        
        (define dark-syntax-pen (send the-pen-list find-or-create-pen "darkorchid" 1 'solid))
        (define dark-syntax-brush (send the-brush-list find-or-create-brush "darkorchid" 'solid))
        (define light-syntax-pen (send the-pen-list find-or-create-pen "plum" 1 'solid))
        (define light-syntax-brush (send the-brush-list find-or-create-brush "plum" 'solid))

        (define dark-template-pen (send the-pen-list find-or-create-pen "seagreen" 1 'solid))
        (define dark-template-brush (send the-brush-list find-or-create-brush "seagreen" 'solid))
        (define light-template-pen (send the-pen-list find-or-create-pen "springgreen" 1 'solid))
        (define light-template-brush (send the-brush-list find-or-create-brush "springgreen" 'solid))
        
        (define dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid))
        (define dark-brush (send the-brush-list find-or-create-brush "blue" 'solid))
        (define light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid))
        (define light-brush (send the-brush-list find-or-create-brush "light blue" 'solid))
        
        (define (module-overview-pasteboard-mixin %)
          (class* % (module-overview-pasteboard<%>)
            
            (inherit get-snip-location
                     begin-edit-sequence
                     end-edit-sequence
                     insert
                     move-to
                     find-first-snip
                     dc-location-to-editor-location
                     find-snip
                     get-canvas)
          
            (define name-length 'long)
            (define/public (set-name-length nl)
              (unless (eq? name-length nl)
                (set! name-length nl)
                (re-add-snips)
                (render-snips)))
            (define/public (get-name-length) name-length)
            
            (field [max-lines #f])
            
            ;; controls if the snips should be moved
            ;; around when the font size is changed.
            ;; set to #f if the user ever moves a
            ;; snip themselves.
            (define dont-move-snips #f)
            
            (field (label-font-size (preferences:get 'drscheme:module-overview:label-font-size)))
            (define/public (get-label-font-size) label-font-size)
            (define/private (get-snip-hspace) (if vertical?
                                                  2
                                                  (* 2 label-font-size)))
            (define/private (get-snip-vspace) (if vertical?
                                                  30
                                                  2))
            (define snip-height #f)
            
            (define font-label-size-callback-running? #f)
            (define new-font-size #f)
            (define/public (set-label-font-size size-to-set)
              (set! new-font-size size-to-set)
              (unless font-label-size-callback-running?
                (set! font-label-size-callback-running? #t)
                (queue-callback
                 (λ ()
                   (set! label-font-size new-font-size)
                   (preferences:set 'drscheme:module-overview:label-font-size 
                                    new-font-size)
                   (set! label-font (find-label-font label-font-size))
                   (begin-edit-sequence)
                   (let loop ([snip (find-first-snip)])
                     (when snip
                       (let ([admin (send snip get-admin)])
                         (when admin
                           (send admin resized snip #t)))
                       (loop (send snip next))))
                   (unless dont-move-snips
                     (render-snips))
                   (end-edit-sequence)
                   (set! new-font-size #f)
                   (set! font-label-size-callback-running? #f))
                 #f)))
            
            (define/public (begin-adding-connections)
              (when max-lines
                (error 'begin-adding-connections "already in begin-adding-connections/end-adding-connections sequence"))
              (set! max-lines 0)
              (begin-edit-sequence)
              (let loop ()
                (let ([s (find-first-snip)])
                  (when s
                    (send s release-from-owner)
                    (loop))))
              (set! level-ht (make-hash-table))
              (set! snip-table (make-hash-table 'equal)))

            (define/public (end-adding-connections)
              (unless max-lines
                (error 'end-adding-connections "not in begin-adding-connections/end-adding-connections sequence"))
              
              (unless (zero? max-lines)
                (let loop ([snip (find-first-snip)])
                  (when snip
                    (when (is-a? snip word-snip/lines%)
                      (send snip normalize-lines max-lines))
                    (loop (send snip next)))))
              
              
              (set! max-lines #f)
              
              (unless (preferences:get 'drscheme:module-browser:show-lib-paths?)
                (remove-lib-linked))
              
              (render-snips)
              (end-edit-sequence))
              
            ;; add-connection : string string boolean symbol -> void
            ;; name-original and name-require and the identifiers for those paths and
            ;; original-filename? and require-filename? are booleans indicating if the names
            ;; are filenames.
            (define/public (add-connection name-original name-require lib-path? require-type)
              (unless max-lines
                (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence"))
              (let* ([original-filename? (file-exists? name-original)]
                     [require-filename? (file-exists? name-require)]
                     [original-snip (find/create-snip name-original original-filename?)]
                     [require-snip (find/create-snip name-require require-filename?)]
                     [original-level (send original-snip get-level)]
                     [require-level (send require-snip get-level)])
                (case require-type 
                  [(require)
                   (add-links original-snip require-snip
                              dark-pen light-pen
                              dark-brush light-brush)]
                  [(require-for-syntax)
                   (add-links original-snip require-snip 
                              dark-syntax-pen light-syntax-pen
                              dark-syntax-brush light-syntax-brush)]
                  [(require-for-template)
                   (add-links original-snip require-snip
                              dark-template-pen light-template-pen
                              dark-template-brush light-template-brush)])
                (when lib-path?
                  (send original-snip add-lib-child require-snip))
                (if (send original-snip get-level)
                    (fix-snip-level require-snip (+ original-level 1))
                    (fix-snip-level original-snip 0))))
            
            ;; fix-snip-level : snip number -> void
            ;; moves the snip (and any children) to at least `new-level'
            ;; doesn't move them if they are already past that level
            (define/private (fix-snip-level snip new-min-level)
              (let loop ([snip snip]
                         [new-min-level new-min-level])
                (let ([current-level (send snip get-level)])
                  (when (or (not current-level)
                            (new-min-level . > . current-level))
                    (send snip set-level new-min-level)
                    (for-each
                     (λ (child) (loop child (+ new-min-level 1)))
                     (send snip get-children))))))
            
            ;; find/create-snip : (union path string) boolean? -> word-snip/lines
            ;; finds the snip with this key, or creates a new
            ;; ones. For the same key, always returns the same snip.
            ;; uses snip-table as a cache for this purpose.
            (define/private (find/create-snip name is-filename?)
              (hash-table-get
               snip-table
               name
               (λ () 
                 (let* ([snip (instantiate word-snip/lines% ()
                                (lines (if is-filename? (count-lines name) #f))
                                (word (let-values ([(_1 name _2) (split-path name)])
                                        (path->string name)))
                                (pb this)
                                (filename (if is-filename? name #f)))])
                   (insert snip)
                   (hash-table-put! snip-table name snip)
                   snip))))
            
            ;; count-lines : string[filename] -> (union #f number)
            ;; effect: updates max-lines
            (define/private (count-lines filename)
              (let ([lines
                     (call-with-input-file filename
                       (λ (port)
                         (let loop ([n 0])
                           (let ([l (read-line port)])
                             (if (eof-object? l)
                                 n
                                 (loop (+ n 1))))))
                       'text)])
                (set! max-lines (max lines max-lines))
                lines))
            
            ;; get-snip-width : snip -> number
            ;; exracts the width of a snip
            (define/private (get-snip-width snip)
              (let ([lb (box 0)]
                    [rb (box 0)])
                (get-snip-location snip lb #f #f)
                (get-snip-location snip rb #f #t)
                (- (unbox rb)
                   (unbox lb))))
            
            ;; get-snip-height : snip -> number
            ;; exracts the width of a snip
            (define/private (get-snip-height snip)
              (let ([tb (box 0)]
                    [bb (box 0)])
                (get-snip-location snip #f tb #f)
                (get-snip-location snip #f bb #t)
                (- (unbox bb)
                   (unbox tb))))
            
            (field [lib-paths-on? (preferences:get 'drscheme:module-browser:show-lib-paths?)])
            (define/public (show-lib-paths on?)
              (unless (eq? on? lib-paths-on?)
                (set! lib-paths-on? on?)
                (begin-edit-sequence)
                (re-add-snips)
                (render-snips)
                (end-edit-sequence)))
            
            (define/private (re-add-snips)
              (begin-edit-sequence)
              (remove-currrently-inserted)
              (if lib-paths-on?
                  (add-all)
                  (remove-lib-linked))
              (end-edit-sequence))
            
            (define/private (remove-lib-linked)
              (remove-currrently-inserted)
              (for-each
               (λ (snip)
                 (insert snip)
                 (let loop ([snip snip])
                   (for-each
                    (λ (child)
                      (unless (memq child (send snip get-lib-children))
                        (insert child)
                        (loop child)))
                    (send snip get-children))))
               (get-top-most-snips)))
                
            (define/private (remove-currrently-inserted)
              (let loop ()
                (let ([snip (find-first-snip)])
                  (when snip
                    (send snip release-from-owner)
                    (loop)))))
            
            (define/private (add-all)
              (let ([ht (make-hash-table)])
                (for-each
                 (λ (snip)
                   (let loop ([snip snip])
                     (unless (hash-table-get ht snip (λ () #f))
                       (hash-table-put! ht snip #t)
                       (insert snip)
                       (for-each loop (send snip get-children)))))
                 (get-top-most-snips))))

            (define/private (get-top-most-snips) (hash-table-get level-ht 0 (λ () null)))
              
            ;; render-snips : -> void
            (define/public (render-snips)
              (begin-edit-sequence)
              (let ([max-minor 0])
                
                ;; major-dim is the dimension that new levels extend along
                ;; minor-dim is the dimension that snips inside a level extend along
                
                (hash-table-for-each
                 level-ht
                 (λ (n v)
                   (set! max-minor (max max-minor (apply + (map (if vertical?
                                                                    (λ (x) (get-snip-width x))
                                                                    (λ (x) (get-snip-height x)))
                                                                v))))))
                
                (let ([levels (quicksort (hash-table-map level-ht list)
                                         (λ (x y) (<= (car x) (car y))))])
                  (let loop ([levels levels]
                             [major-dim 0])
                    (cond
                      [(null? levels) (void)]
                      [else
                       (let* ([level (car levels)]
                              [n (car level)]
                              [this-level-snips (cadr level)]
                              [this-minor (apply + (map (if vertical? 
                                                            (λ (x) (get-snip-width x))
                                                            (λ (x) (get-snip-height x)))
                                                        this-level-snips))]
                              [this-major (apply max (map (if vertical? 
                                                              (λ (x) (get-snip-height x))
                                                              (λ (x) (get-snip-width x)))
                                                          this-level-snips))])
                         (let loop ([snips this-level-snips]
                                    [minor-dim (/ (- max-minor this-minor) 2)])
                           (unless (null? snips)
                             (let* ([snip (car snips)]
                                    [new-major-coord
                                     (+ major-dim
                                        (floor
                                         (- (/ this-major 2) 
                                            (/ (if vertical? 
                                                   (get-snip-height snip)
                                                   (get-snip-width snip))
                                               2))))])
                               (if vertical?
                                   (move-to snip minor-dim new-major-coord)
                                   (move-to snip new-major-coord minor-dim))
                               (loop (cdr snips)
                                     (+ minor-dim
                                        (if vertical?
                                            (get-snip-hspace)
                                            (get-snip-vspace))
                                        (if vertical?
                                            (get-snip-width snip)
                                            (get-snip-height snip)))))))
                         (loop (cdr levels)
                               (+ major-dim 
                                  (if vertical? 
                                      (get-snip-vspace)
                                      (get-snip-hspace))
                                  this-major)))]))))
              (end-edit-sequence))
            
            (define/override (on-mouse-over-snips snips)
              (mouse-currently-over snips))
            
            (define/override (on-double-click snip event)
              (cond
                [(is-a? snip boxed-word-snip<%>) 
                 (let ([fn (send snip get-filename)])
                   (when fn
                     (handler:edit-file fn)))]
                [else (super on-double-click snip event)]))
              
            (define/override (on-event evt)
              (cond
                [(send evt button-down? 'right)
                 (let ([ex (send evt get-x)]
                       [ey (send evt get-y)])
                   (let-values ([(x y) (dc-location-to-editor-location ex ey)])
                     (let ([snip (find-snip x y)]
                           [canvas (get-canvas)])
                       (let ([right-button-menu (make-object popup-menu%)])
                         (when (and snip
                                    (is-a? snip boxed-word-snip<%>)
                                    canvas
                                    (send snip get-filename))
                           (instantiate menu-item% ()
                             (label 
                              (trim-string
                               (format open-file-format
                                       (path->string (send snip get-filename)))
                               200))
                             (parent right-button-menu)
                             (callback
                              (λ (x y)
                                (handler:edit-file
                                 (send snip get-filename))))))
                         (instantiate menu-item% ()
                           (label (string-constant module-browser-open-all))
                           (parent right-button-menu)
                           (callback
                            (λ (x y)
                              (let loop ([snip (find-first-snip)])
                                (when snip
                                  (when (is-a? snip boxed-word-snip<%>)
                                    (let ([filename (send snip get-filename)])
                                      (handler:edit-file filename)))
                                  (loop (send snip next)))))))
                         (send canvas popup-menu
                               right-button-menu
                               (+ (send evt get-x) 1)
                               (+ (send evt get-y) 1))))))]
                [else (super on-event evt)]))
            
            (super-instantiate ())))
        
        (define (trim-string str len)
          (cond
            [(<= (string-length str) len) str]
            [else (substring str (- (string-length str) len) (string-length str))]))
        
        (define (level-mixin %)
          (class %
            (field (level #f))
            (define/public (get-level) level)
            (define/public (set-level _l) 
              (when level
                (hash-table-put! level-ht level
                                 (remq this (hash-table-get level-ht level))))
              (set! level _l)
              (hash-table-put! level-ht level 
                               (cons this (hash-table-get level-ht level (λ () null)))))
            
            (super-instantiate ())))
        
        (define (boxed-word-snip-mixin %)
          (class* % (boxed-word-snip<%>)
            (init-field word
                        filename
                        lines
                        pb)
            
            (field [lib-children null])
            (define/public (get-lib-children) lib-children)
            (define/public (add-lib-child child)
              (unless (memq child lib-children)
                (set! lib-children (cons child lib-children))))
            
            (define/public (get-filename) filename)
            (define/public (get-word) word)
            (define/public (get-lines) lines)
            
            (field (lines-brush #f))
            (define/public (normalize-lines n)
              (if lines
                  (let* ([grey (inexact->exact (floor (- 255 (* 255 (sqrt (/ lines n))))))])
                    (set! lines-brush (send the-brush-list find-or-create-brush
                                            (make-object color% grey grey grey)
                                            'solid)))
                  (set! lines-brush (send the-brush-list find-or-create-brush
                                          "salmon"
                                          'solid))))
            
            (field (snip-width 0)
                   (snip-height 0))
            
            (define/override (get-extent dc x y wb hb descent space lspace rspace)
              (cond
                [(equal? (name->label) "")
                 (set! snip-width 15)
                 (set! snip-height 15)]
                [else
                 (let-values ([(w h a d) (send dc get-text-extent (name->label) label-font)])
                   (set! snip-width (+ w 4))
                   (set! snip-height (+ h 4)))])
              (set-box/f wb snip-width)
              (set-box/f hb snip-height)
              (set-box/f descent 0)
              (set-box/f space 0)
              (set-box/f lspace 0)
              (set-box/f rspace 0))
            
            (define/override (draw dc x y left top right bottom dx dy draw-caret)
              (let ([old-font (send dc get-font)]
                    [old-text-foreground (send dc get-text-foreground)]
                    [old-brush (send dc get-brush)])
                (send dc set-font label-font)
                (when lines-brush
                  (send dc set-brush lines-brush))
                (when (and (or (<= left x right)
                               (<= left (+ x snip-width) right))
                           (or (<= top y bottom)
                               (<= top (+ y snip-height) bottom)))
                  (send dc draw-rectangle x y snip-width snip-height)
                  (send dc set-text-foreground text-color)
                  (send dc draw-text (name->label) (+ x 2) (+ y 2)))
                (send dc set-brush old-brush)
                (send dc set-text-foreground old-text-foreground)
                (send dc set-font old-font)))
                          
            ;; name->label : path -> string
            ;; constructs a label for the little boxes in terms
            ;; of the filename.
            
            (define last-name #f)
            (define last-size #f)
            
            (define/private (name->label)
              (let ([this-size (send pb get-name-length)])
                (cond
                  [(eq? this-size last-size) last-name]
                  [else
                   (set! last-size this-size)
                   (set! last-name
                         (case last-size
                           [(short)
                            (if (string=? word "")
                                ""
                                (string (string-ref word 0)))]
                           [(medium)
                            (let ([m (regexp-match #rx"^(.*)\\.[^.]*$" word)])
                              (let ([short-name (if m (cadr m) word)])
                                (if (string=? short-name "")
                                    ""
                                    (let ([ms (regexp-match* #rx"-[^-]*" short-name)])
                                      (cond
                                        [(null? ms)
                                         (substring short-name 0 (min 2 (string-length short-name)))]
                                        [else
                                         (apply string-append
                                                (cons (substring short-name 0 1)
                                                      (map (λ (x) (substring x 1 2))
                                                           ms)))])))))]
                           [(long) word]))
                   last-name])))

            (super-new)))
        
        (define word-snip/lines% (level-mixin (boxed-word-snip-mixin (graph-snip-mixin snip%))))
        
        (define draw-lines-pasteboard% (module-overview-pasteboard-mixin
                                        (graph-pasteboard-mixin
                                         pasteboard:basic%)))
        (make-object draw-lines-pasteboard%))
      
      
;                                                                                    
;                                                                                    
;                                                                                    
;                                                                                    
;                                                                                    
;                                                                                    
;   ; ;;    ; ;   ;;;     ;;;    ;;;    ;;;    ;;;       ; ;;    ; ;   ;;;     ;; ;  
;   ;;  ;   ;;   ;   ;   ;   ;  ;   ;  ;      ;          ;;  ;   ;;   ;   ;   ;  ;;  
;   ;    ;  ;   ;     ; ;      ;    ;  ;;     ;;         ;    ;  ;   ;     ; ;    ;  
;   ;    ;  ;   ;     ; ;      ;;;;;;   ;;     ;;        ;    ;  ;   ;     ; ;    ;  
;   ;    ;  ;   ;     ; ;      ;          ;      ;       ;    ;  ;   ;     ; ;    ;  
;   ;;  ;   ;    ;   ;   ;   ;  ;         ;      ;       ;;  ;   ;    ;   ;   ;  ;;  
;   ; ;;    ;     ;;;     ;;;    ;;;;  ;;;    ;;;        ; ;;    ;     ;;;     ;; ;  
;   ;                                                    ;                        ;  
;   ;                                                    ;                   ;    ;  
;   ;                                                    ;                    ;;;;   


      (define process-program-unit
        (unit 
          (import progress-channel
                  connection-channel)
          (export add-connections)
        
          (define visited-hash-table (make-hash-table 'equal))
          
          ;; add-connections : (union syntax string[filename]) -> (union #f string)
          ;; recursively adds a connections from this file and
          ;; all files it requires
          ;; returns a string error message if there was an error compiling
          ;; the program
          (define (add-connections filename/stx)
            (cond
              [(string? filename/stx)
               (add-filename-connections filename/stx)]
              [(syntax? filename/stx)
               (add-syntax-connections filename/stx)]))
          
          ;; add-syntax-connections : syntax -> void
          (define (add-syntax-connections stx)
            (let ([module-codes (map compile (expand-syntax-top-level-with-compile-time-evals/flatten stx))])
              (for-each
               (λ (module-code)
                 (when (compiled-module-expression? module-code)
                   (let* ([name (extract-module-name stx)]
                          [base 
                           (build-module-filename
                            (if (regexp-match #rx"^," name)
                                (substring name 1 (string-length name))
                                (build-path (current-load-relative-directory) name)))])
                     (add-module-code-connections base module-code))))
               module-codes)))
          
          (define (build-module-filename str)
            (let ([try (λ (ext)
                         (let ([tst (bytes->path (bytes-append (path->bytes str) ext))])
                           (and (file-exists? tst)
                                tst)))])
              (or (try #".ss")
                  (try #".scm")
                  (try #"")
                  str)))
              
          ;; add-filename-connections : string -> void
          (define (add-filename-connections filename)
            (add-module-code-connections filename (get-module-code filename)))
          
          (define (add-module-code-connections module-name module-code)
            (unless (hash-table-get visited-hash-table module-name (λ () #f))
              (async-channel-put progress-channel (format adding-file module-name))
              (hash-table-put! visited-hash-table module-name #t)
              (let-values ([(imports fs-imports ft-imports) (module-compiled-imports module-code)])
                (let ([requires (extract-filenames imports module-name)]
                      [syntax-requires (extract-filenames fs-imports module-name)]
                      [template-requires (extract-filenames ft-imports module-name)])
                  (for-each (λ (require)
                              (add-connection module-name
                                              (req-filename require)
                                              (req-lib? require)
                                              'require)
                              (add-filename-connections (req-filename require)))
                            requires)
                  (for-each (λ (syntax-require)
                              (add-connection module-name 
                                              (req-filename syntax-require)
                                              (req-lib? syntax-require)
                                              'require-for-syntax)
                              (add-filename-connections (req-filename syntax-require)))
                            syntax-requires)
                  (for-each (λ (require)
                              (add-connection module-name
                                              (req-filename require)
                                              (req-lib? require)
                                              'require-for-template)
                              (add-filename-connections (req-filename require)))
                            template-requires)))))

          ;; add-connection : string string boolean symbol -> void
          ;; name-original and name-require and the identifiers for those paths and
          ;; original-filename? and require-filename? are booleans indicating if the names
          ;; are filenames.
          (define (add-connection name-original name-require is-lib? require-type)
            (async-channel-put connection-channel (list name-original 
                                                        name-require  
                                                        is-lib?
                                                        require-type)))
          
          (define (extract-module-name stx)
            (syntax-case stx ()
              [(module m-name rest ...)
               (and (eq? (syntax-e (syntax module)) 'module)
                    (identifier? (syntax m-name)))
               (format "~a" (syntax-object->datum (syntax m-name)))]
              [else unknown-module-name]))
          
          ;; extract-filenames : (listof (union symbol module-path-index)) string[module-name] ->
          ;;                     (listof req)
          (define (extract-filenames direct-requires base)
            (let loop ([direct-requires direct-requires])
              (cond
                [(null? direct-requires) null]
                [else (let ([dr (car direct-requires)])
                        (if (module-path-index? dr)
                            (cons (make-req (simplify-path (expand-path (resolve-module-path-index dr base)))
                                            (is-lib? dr))
                                  (loop (cdr direct-requires)))
                            (loop (cdr direct-requires))))])))
          
          (define (is-lib? dr)
            (and (module-path-index? dr)
                 (let-values ([(a b) (module-path-index-split dr)])
                   (and (pair? a)
                        (eq? 'lib (car a))))))))

      
;                                                                
;                                                                
;                                                                
;    ;;;                                      ;;;;   ;     ;  ;  
;   ;                                        ;    ;  ;     ;  ;  
;   ;                                       ;        ;     ;  ;  
;  ;;;;  ; ;  ;;;    ; ;;  ;;     ;;;       ;        ;     ;  ;  
;   ;    ;;  ;   ;   ;;  ;;  ;   ;   ;      ;        ;     ;  ;  
;   ;    ;       ;   ;   ;   ;  ;    ;      ;        ;     ;  ;  
;   ;    ;    ;;;;   ;   ;   ;  ;;;;;;      ;     ;  ;     ;  ;  
;   ;    ;   ;   ;   ;   ;   ;  ;           ;     ;  ;     ;  ;  
;   ;    ;   ;   ;   ;   ;   ;   ;           ;    ;  ;     ;  ;  
;   ;    ;    ;;;;;  ;   ;   ;    ;;;;        ;;;;;   ;;;;;   ;  
;                                                                
;                                                                
;                                                                

      
      (define (module-overview/file filename parent)
        (define progress-frame (parameterize ([current-eventspace (make-eventspace)])
                                 (instantiate frame% ()
                                   (parent parent)
                                   (label progress-label)
                                   (width 600))))
        (define progress-message (instantiate message% ()
                                   (label "")
                                   (stretchable-width #t)
                                   (parent progress-frame)))
        
        (define thd 
          (thread
           (λ ()
             (sleep 3)
             (send progress-frame show #t))))
        
        (define text/pos 
          (let ([t (make-object text%)])
            (send t load-file filename)
            (drscheme:language:make-text/pos
             t
             0
             (send t last-position))))
        
        (define update-label void)
        
        (define (show-status str)
          (send progress-message set-label str))
        
        (define pasteboard (make-module-overview-pasteboard 
                            #f
                            (λ (x) (update-label x))))
        
        (let ([success? (fill-pasteboard pasteboard text/pos show-status void)])
          (kill-thread thd)
          (send progress-frame show #f)
          (when success?
            (let ()
              (define frame (instantiate overview-frame% ()
                              (label (string-constant module-browser))
                              (width (preferences:get 'drscheme:module-overview:window-width))
                              (height (preferences:get 'drscheme:module-overview:window-height))
                              (alignment '(left center))))
              (define vp (instantiate vertical-panel% ()
                           (parent (send frame get-area-container))
                           (alignment '(left center))))
              (define root-message (instantiate message% ()
                                     (label 
                                      (format (string-constant module-browser-root-filename)
                                              filename))
                                     (parent vp)
                                     (stretchable-width #t)))
              (define label-message (instantiate message% ()
                                      (label "")
                                      (parent vp)
                                      (stretchable-width #t)))
              (define font-size-gauge
                (instantiate slider% ()
                  (label font-size-gauge-label)
                  (min-value 1)
                  (max-value 72)
                  (init-value (preferences:get 'drscheme:module-overview:label-font-size))
                  (parent vp)
                  (callback
                   (λ (x y)
                     (send pasteboard set-label-font-size (send font-size-gauge get-value))))))
              (define lib-paths-checkbox
                (instantiate check-box% ()
                  (label lib-paths-checkbox-constant)
                  (parent vp)
                  (callback
                   (λ (x y)
                     (send pasteboard show-lib-paths (send lib-paths-checkbox get-value))))))
              
              (define ec (make-object canvas:basic% vp pasteboard))
              
              (send lib-paths-checkbox set-value (preferences:get 'drscheme:module-browser:show-lib-paths?))
              (set! update-label
                    (λ (s)
                      (if (and s (not (null? s)))
                          (let* ([currently-over (car s)]
                                 [fn (send currently-over get-filename)]
                                 [lines (send currently-over get-lines)])
                            (when (and fn lines)
                              (send label-message set-label
                                    (format filename-constant fn lines))))
                          (send label-message set-label ""))))
              
              ;; shouldn't be necessary here -- need to find callback on editor
              (send pasteboard render-snips)
              
              (send frame show #t)))))
      
      (define (fill-pasteboard pasteboard text/pos show-status send-user-thread/eventspace)
        (define progress-channel (make-async-channel))
        (define connection-channel (make-async-channel))
        
        (define-values/invoke-unit (add-connections) process-program-unit #f progress-channel connection-channel)
        
        ;; =user thread=
        (define (iter sexp continue)
          (cond
            [(eof-object? sexp) 
             (custodian-shutdown-all user-custodian)]
            [else
             (add-connections sexp)
             (continue)]))
        (define init-complete (make-semaphore 0))
        
        (define user-custodian #f)
        (define user-thread #f)
        (define error-str #f)
        
        (define init-dir
          (let* ([bx (box #f)]
                 [filename (send (drscheme:language:text/pos-text text/pos) get-filename bx)])
            (if (and filename
                     (not (unbox bx)))
                (let-values ([(base name dir) (split-path filename)])
                  base)
                (current-directory))))
        
        (define (init)
          (set! user-custodian (current-custodian))
          (set! user-thread (current-thread))
          (moddep-current-open-input-file
           (λ (filename)
             (let* ([p (open-input-file filename)]
                    [wxme? (regexp-match-peek #rx#"^WXME" p)])
               (if wxme?
                   (let ([t (new text%)])
                     (close-input-port p)
                     (send t load-file filename)
                     (let ([prt (open-input-text-editor t)])
                       (port-count-lines! prt)
                       prt))
                   p))))
          (current-load-relative-directory init-dir)
          (current-directory init-dir)
          (error-display-handler 
           (λ (str exn)
             (set! error-str str)
             (custodian-shutdown-all user-custodian)))
          (semaphore-post init-complete))
        (define (kill-termination) (void))
        (define complete-program? #t)
        
        (define stupid-internal-define-syntax1
          ((drscheme:eval:traverse-program/multiple
            (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))
            init
            kill-termination)
           text/pos
           iter
           complete-program?))
        
        (semaphore-wait init-complete)
        (send-user-thread/eventspace user-thread user-custodian)
        
        ;; this thread puts a "cap" on the end of the connection-channel
        ;; so that we know when we've gotten to the end.
        ;; this ensures that we can completely flush out the
        ;; connection-channel.
        (thread
         (λ ()
           (sync (thread-dead-evt user-thread))
           (async-channel-put connection-channel 'done)))
        
        (send pasteboard begin-adding-connections)
        (let ([evt
               (choice-evt
                (handle-evt progress-channel (λ (x) (cons 'progress x)))
                (handle-evt connection-channel (λ (x) (cons 'connect x))))])
          (let loop ()
            (let* ([evt-value (yield evt)]
                   [key (car evt-value)]
                   [val (cdr evt-value)])
              (case key
                [(progress) 
                 (show-status val)
                 (loop)]
                [(connect)
                 (unless (eq? val 'done)
                   (let ([name-original (first val)]
                         [name-require (second val)]
                         [lib-path? (third val)]
                         [require-type (fourth val)])
                     (send pasteboard add-connection name-original name-require lib-path? require-type))
                   (loop))]))))
        (send pasteboard end-adding-connections)
        
        (custodian-shutdown-all user-custodian)
        
        (cond
          [error-str
           (message-box 
            (string-constant module-browser)
            (format (string-constant module-browser-error-expanding)
                    error-str))
           #f]
          [else
           #t]))
      
      (define overview-frame%
        (class (drscheme:frame:basics-mixin
                frame:standard-menus%)
          (define/override (edit-menu:between-select-all-and-find menu) (void))
          (define/override (edit-menu:between-redo-and-cut menu) (void))
          (define/override (edit-menu:between-find-and-preferences menu) (void))
          
          (define/override (edit-menu:create-cut?) #f)
          (define/override (edit-menu:create-copy?) #f)
          (define/override (edit-menu:create-paste?) #f)
          (define/override (edit-menu:create-clear?) #f)
          (define/override (edit-menu:create-select-all?) #f)
          
          (define/override (on-size w h)
            (preferences:set 'drscheme:module-overview:window-width w)
            (preferences:set 'drscheme:module-overview:window-height h)
            (super on-size w h))
          (super-instantiate ()))))))
