#lang racket

#|

This test checks:

  - if opening frames/tabs leaks,

  - if DrRacket writes to the filesystem during startup or
    while opening tabs/frames

  - if there are any adjacent separators in the menus

  - if there are any duplicate shortcuts in the menus

  - that the logger GUI is not completely broken (checks
    that it opens, that it catches a GC message, and that
    it closes)

|#

(require "private/drracket-test-util.rkt"
         drracket/private/local-member-names
         racket/gui/base
         framework
         string-constants)

(define (main)
  (parameterize ([current-security-guard
                  (make-security-guard
                   (current-security-guard)
                   (λ (who pth what)
                     (when (member 'write what)
                       (error who "Writing to the file system is not allowed"))
                     (when (member 'delete what)
                       (error who "Deleting files is not allowed")))
                   void
                   void)])
    (fire-up-drracket-and-run-tests 
     #:prefs '([plt:framework-pref:drracket:online-compilation-default-on #f]) 
     (λ ()
       (define drr (wait-for-drracket-frame))
       (check-log-panel drr)
       (check-menus drr)
       
       (try-to-find-leak "online compilation disabled:" void)
       
       (preferences:set 'drracket:online-compilation-default-on #t)
       
       (try-to-find-leak "online compilation enabled:" wait-for-online-compilation-to-finish)))))

(define (wait-for-online-compilation-to-finish frame) 
  (let loop ([i 0])
    (define current-colors (send frame get-online-expansion-colors))
    (unless (equal? current-colors '("forestgreen"))
      (sleep 1)
      (loop (+ i 1)))))

(define (try-to-find-leak online-compilation-string extra-waiting)
  (define drs-frame1 (wait-for-drracket-frame))
  (sync (system-idle-evt))

  (for ([tries (in-range 3)])
    (test:menu-select "File" "New Tab")
    (sync (system-idle-evt))
    
    (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab)))
    (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace)))
    
    (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab"))
    (sync (system-idle-evt))
    
    (test:menu-select "File" "New")
    (sync (system-idle-evt))
    
    (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1)))
    (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace)))
    
    (queue-callback/res
     (λ () (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-defs) load-file
                 (collection-file-path "rep.rkt" "drracket" "private"))))
    (sleep 2)
    (extra-waiting (weak-box-value drs-frame2b))
    (sync (system-idle-evt))
    
    (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window"))
    (sync (system-idle-evt))
    
    (let loop ([n 30])
      (cond
        [(zero? n) 
         (when (weak-box-value drs-tabb)
           (eprintf "~a tab leak!\n" online-compilation-string))
         (when (weak-box-value drs-frame2b)
           (eprintf "~a frame leak!\n" online-compilation-string))
         (when (weak-box-value tab-nsb)
           (eprintf "~a tab namespace leak!\n" online-compilation-string))
         (when (weak-box-value frame2-nsb)
           (eprintf "~a frame namespace leak!\n" online-compilation-string))]
        [else
         (collect-garbage) (sync (system-idle-evt))
         (when (ormap weak-box-value 
                      (list drs-tabb
                            tab-nsb
                            drs-frame2b
                            frame2-nsb))
           (loop (- n 1)))]))))
  
(define (check-menus frame)
  
  (define shortcuts (make-hash))
  
  (define (process-container container)
    (define sub-items (send container get-items))
    (unless (null? sub-items)
      (record-shortcut (car sub-items))
      (when (is-a? (car sub-items) menu-item-container<%>)
        (process-container (car sub-items)))
      (define printed? #f)
      (for ([prev-item (in-list sub-items)]
            [item (in-list (cdr sub-items))])
        (record-shortcut item)
        (when (and (is-a? prev-item separator-menu-item%)
                   (is-a? item separator-menu-item%)
                   (not printed?))
          (set! printed? #t)
          (eprintf "found two adjacent separator items in: ~s:\n" (get-names container))
          (for ([item (in-list sub-items)])
            (eprintf "  ~a\n" (get-lab item)))
          (eprintf "\n"))
        (when (is-a? item menu-item-container<%>)
          (process-container item)))))
  
  (define (record-shortcut item)
    (when (is-a? item selectable-menu-item<%>)
      (when (send item get-shortcut)
        (define k (append (sort (send item get-shortcut-prefix)
                                string<=?
                                #:key symbol->string)
                          (list (send item get-shortcut))))
        (hash-set! shortcuts 
                   k
                   (cons (send item get-label)
                         (hash-ref shortcuts k '()))))))
  
  (define (get-lab item)
    (cond
      [(is-a? item labelled-menu-item<%>)
       (send item get-label)]
      [(is-a? item separator-menu-item%)
       "---------"]
      [else #f]))
  
  (define (get-names item)
    (let loop ([item item])
      (cond
        [(is-a? item menu-item<%>)
         (cons (get-lab item)
               (loop (send item get-parent)))]
        [else
         '()])))
  
  (define (check-shortcuts)
    (for ([(k v) (in-hash shortcuts)])
      (unless (= 1 (length v))
        (eprintf "found multiple menu items with the shortcut ~s: ~s\n"
                 k v))))
  
  (process-container (send frame get-menu-bar))
  (check-shortcuts))

(define (check-log-panel drr)
  
  (define (find-log-messages-message)
    (let loop ([p drr])
      (cond
        [(is-a? p area-container<%>)
         (for/or ([c (in-list (send p get-children))])
           (loop c))]
        [(is-a? p message%)
         (and (equal? (send p get-label) (string-constant log-messages))
              p)]
        [else #f])))
  
  (test:menu-select "View" "Show Log")
  
  ;; wait for the log window to show up.
  (poll-until
   (λ ()
     (queue-callback/res find-log-messages-message)))
  
  (collect-garbage)
  
  (define logger-string
    (poll-until
     (λ ()
       (define str
         (queue-callback/res
          (λ ()
            (define msg (find-log-messages-message))
            (define msg-parent-parent (send (send msg get-parent) get-parent))
            (let loop ([p msg-parent-parent])
              (cond
                [(is-a? p area-container<%>)
                 (for/or ([c (in-list (send p get-children))])
                   (loop c))]
                [(is-a? p editor-canvas%)
                 (send (send p get-editor) get-text)]
                [else #f])))))
       (and str
            (not (equal? str ""))
            str))))
  
  (unless (regexp-match #rx"GC: [0-9]+:MAJ" logger-string)
    (error 'check-log-panel "didn't find GC log message: ~s" logger-string))
  
  (test:menu-select "View" "Hide Log")
  
  (poll-until
   (λ ()
     (not (queue-callback/res find-log-messages-message)))))

(main)