(module mem mzscheme
  (require "test-suite-utils.ss")
  
  ; mem-boxes : (list-of (list string (list-of (weak-box TST))))
  (send-sexp-to-mred '(define mem-boxes null))
  
  (define mem-count 10)
  
  (define (test-allocate tag open close)
    (send-sexp-to-mred
     `(let ([new-boxes
             (let loop ([n ,mem-count])
               (cond
                 [(zero? n) null]
                 [else
                  (let* ([o (,open)]
                         [b (make-weak-box o)])
                    (,close o)
                    
                    ;; break at least that link.
                    (set! o #f)

                    ;; flush pending events
                    (let ([s (make-semaphore 0)])
                      (queue-callback (lambda () (semaphore-post s)) #f)
                      (yield s))
                    
                    (cons b (loop (- n 1))))]))])
        (sleep/yield 1/10) (collect-garbage)
        (sleep/yield 1/10) (collect-garbage)
        (sleep/yield 1/10) (collect-garbage)
        (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
  
  (define (done)
    (send-sexp-to-mred
     `(begin
        (yield) (collect-garbage)
        (yield) (collect-garbage)
        (yield) (collect-garbage)
        (yield) (collect-garbage)
        (yield) (collect-garbage)
        (yield) (collect-garbage)
        (let* ([f (make-object dialog% "Results" #f 300 500)]
               [text (make-object text%)]
               [ec (make-object editor-canvas% f text)]
               [hp (instantiate horizontal-panel% () 
                     (parent f)
                     (stretchable-width #f)
                     (stretchable-height #f))]
               [vp (instantiate vertical-panel% ()
                     (parent hp)
                     (stretchable-width #f)
                     (stretchable-height #f))]
               [gc-canvas (make-object canvas% hp '(border))]
               [anything? #f])
          
          (define (update-gui)
            (send text erase)
            (let ([anything? #f])
              (send text begin-edit-sequence)
              (for-each
               (lambda (boxl)
                 (let* ([tag (car boxl)]
                        [boxes (cadr boxl)]
                        [calc-results
                         (lambda ()
                           (let loop ([boxes boxes]
                                      [n 0])
                             (cond
                               [(null? boxes) n]
                               [else (if (weak-box-value (car boxes))
                                         (loop (cdr boxes) (+ n 1))
                                         (loop (cdr boxes) n))])))])
                   (let ([res (calc-results)])
                     (when (> res 0)
                       (set! anything? #t)
                       (send text insert (format "~a: ~a of ~a\n" tag res ,mem-count))))))
               (reverse mem-boxes))
              (unless anything?
                (send text insert "Nothing!\n"))
              (send text end-edit-sequence)))
          
          (update-gui)
          
          (let ([onb (icon:get-gc-on-bitmap)]
                [offb (icon:get-gc-off-bitmap)])
            (when (and (send onb ok?)
                       (send offb ok?))
              (send* gc-canvas
                (min-client-width (max (send gc-canvas min-width) (send onb get-width)))
                (min-client-height (max (send gc-canvas min-height) (send onb get-height)))
                (stretchable-width #f)
                (stretchable-height #f))
              (register-collecting-blit gc-canvas 
                                        0 0
                                        (send onb get-width)
                                        (send onb get-height)
                                        onb offb)))
          
          (make-object button% 
            "Collect" 
            vp
            (lambda (x y)
              (send text erase)
              (send text insert "Collecting Garbage\n")
              (collect-garbage)(collect-garbage)(collect-garbage)
              (collect-garbage)(collect-garbage)(collect-garbage)
              (collect-garbage)(collect-garbage)(collect-garbage)
              (update-gui)))
          (make-object button% "Close" vp (lambda (x y) (send f show #f)))
          (send f show #t)))))
  
  (define (test-frame-allocate %)
    (let ([name (format "~s" %)])
      (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
      (test-allocate name
                     `(lambda () (let ([f (make-object ,% ,name)])
                                   (send f show #t)
                                   (yield) (yield)
                                   f))
                     `(lambda (f)
                        (yield) (yield)
                        (send f close)
                        (when (send f is-shown?)
                          (error 'test-frame-allocate "~a instance didn't close" ',%))
                        (yield) (yield)))
      (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
  
  (test-allocate "frame%"
                 '(lambda () (let ([f (make-object frame% "test frame")])
                               (send f show #t)
                               f))
                 '(lambda (f) (send f show #f)))
  
  
  (define (test-editor-allocate object-name)
    (test-allocate (symbol->string object-name)
                   `(lambda () (make-object ,object-name))
                   '(lambda (e) (send e on-close))))
  
  (test-editor-allocate 'text:basic%)
  (test-editor-allocate 'text:keymap%)
  (test-editor-allocate 'text:autowrap%)
  (test-editor-allocate 'text:file%)
  (test-editor-allocate 'text:clever-file-format%)
  (test-editor-allocate 'text:backup-autosave%)
  (test-editor-allocate 'text:searching%)
  (test-editor-allocate 'text:info%)
  
  (test-editor-allocate 'pasteboard:basic%)
  (test-editor-allocate 'pasteboard:keymap%)
  (test-editor-allocate 'pasteboard:file%)
  (test-editor-allocate 'pasteboard:backup-autosave%)
  (test-editor-allocate 'pasteboard:info%)
  
  (test-editor-allocate 'scheme:text%)
  
  (test-allocate "text:return%"
                 '(lambda () (make-object text:return% void))
                 '(lambda (t) (void)))
  
  (test-frame-allocate '(class frame% (inherit show) (define/public (close) (show #f)) (super-new)))
  (test-frame-allocate 'frame:basic%)
  (test-frame-allocate 'frame:info%)
  (test-frame-allocate 'frame:text-info%)
  (test-frame-allocate 'frame:pasteboard-info%)
  (test-frame-allocate 'frame:standard-menus%)
  
  (test-frame-allocate 'frame:text%)
  (test-frame-allocate 'frame:searchable%)
  
  (test-frame-allocate 'frame:pasteboard%)
  (done))