add the increment-splash argument to start-splash

Author: rfindler

gui-doc/scribblings/framework/splash.scrbl

@@ -32,7 +32,9 @@ that number to control the gauge along the bottom of the splash screen.
                               (is-a?/c bitmap%)
                               (cons/c (is-a?/c bitmap%)
                                       (is-a?/c bitmap%)))
-                        #f])
+                        #f]
+                       [#:increment-splash increment-splash
+                        (or/c #f (-> (-> void?) any))])
          void?]{
   Starts a new splash screen. The splash screen is created in its own, new 
   @tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace}.
@@ -63,6 +65,14 @@ that number to control the gauge along the bottom of the splash screen.
 
   The @racket[frame-icon] is used just like the value of the parameter @racket[frame:current-icon] is used,
   but for the splash screen.
+
+ If @racket[increment-splash] is @racket[#false],
+ @racket[start-splah] sets the @racket[current-load]
+ parameter to a function that advances the splash screen
+ progress bar. If @racket[increment-splash] is a function, it
+ calls the function with a thunk that will advance the splash
+ screen progress bar.
+
 }
 
 @defproc[(shutdown-splash) void?]{

gui-lib/framework/splash.rkt

@@ -36,7 +36,9 @@
                          exact-nonnegative-integer?))
          string?
          exact-nonnegative-integer?)
-        (#:allow-funny?
+        (#:increment-splash
+         (or/c #f (-> (-> void?) any))
+         #:allow-funny?
          boolean?
          #:frame-icon
          (or/c #f
@@ -185,13 +187,18 @@
    (set! icons (cons (make-icon bm x y) icons))
    (refresh-splash)))
 
-(define (start-splash splash-draw-spec _splash-title width-default 
+(define (start-splash splash-draw-spec _splash-title width-default
+                      #:increment-splash [increment-splash #f]
                       #:allow-funny? [allow-funny? #f]
                       #:frame-icon [frame-icon #f])
   (unless allow-funny? (set! funny? #f))
   (set! splash-title _splash-title)
   (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
 
+  (cond
+    [increment-splash (increment-splash inc-splash)]
+    [else (install-splash-load-handler)])
+
   (on-splash-eventspace/ret
    (let/ec k
      (define (no-splash)
@@ -288,7 +295,7 @@
 ;; example)
 (define splash-range-ready? #f)
 
-(define (splash-load-handler old-load f expected)
+(define (inc-splash)
   (set! splash-current-width (+ splash-current-width 1))
   (when (<= splash-current-width splash-max-width)
     (let ([splash-save-width splash-current-width])
@@ -298,22 +305,27 @@
        (when (or (not (member (get-gauge) (send gauge-panel get-children)))
                  ;; when the gauge is not visible, we'll redraw the canvas regardless
                  (refresh-splash-on-gauge-change? splash-save-width splash-max-width))
-         (refresh-splash)))))
+         (refresh-splash))))))
+
+(define (splash-load-handler old-load f expected)
+  (inc-splash)
   (old-load f expected))
 
-(let ([make-compilation-manager-load/use-compiled-handler
-       (if (or (getenv "PLTDRCM")
-               (getenv "PLTDRDEBUG"))
-           (parameterize ([current-namespace (make-base-namespace)])
-             (dynamic-require 'compiler/cm
-                              'make-compilation-manager-load/use-compiled-handler))
-           #f)])
+(define (install-splash-load-handler)
+  (set! install-splash-load-handler void)
+  (define make-compilation-manager-load/use-compiled-handler
+    (if (or (getenv "PLTDRCM")
+            (getenv "PLTDRDEBUG"))
+        (parameterize ([current-namespace (make-base-namespace)])
+          (dynamic-require 'compiler/cm
+                           'make-compilation-manager-load/use-compiled-handler))
+        #f))
 
   (current-load
    (let ([old-load (current-load)])
      (λ (f expected)
        (splash-load-handler old-load f expected))))
-  
+
   (when make-compilation-manager-load/use-compiled-handler
     (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
     (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))))