.

original commit: 08c4f94ddcb288c6852b57daff5a45170f19d6ca

collects/framework/framework.ss

@@ -47,7 +47,7 @@
     "on the number."
     ""
     "See also"
-    "@flink number-snip:number-snip:make-fraction-snip %"
+    "@flink number-snip:make-fraction-snip %"
     ".")
    (number-snip:make-fraction-snip
     (number? boolean? . -> . (is-a?/c snip%))
@@ -58,7 +58,7 @@
     "on the number, when shown in the decimal state."
     ""
     "See also"
-    "@flink drscheme:number-snip:make-repeating-decimal-snip %"
+    "@flink number-snip:make-repeating-decimal-snip %"
     ".")   
    (version:add-spec
     (any? any? . -> . void?)
@@ -229,7 +229,7 @@
     "default preferences.")
 
    (preferences:add-panel
-    ((union string? (cons/p string? (listof string?)))
+    ((union string? (cons/c string? (listof string?)))
      ((is-a?/c area-container-window<%>) 
       . ->d .
       (lambda (parent)
@@ -479,8 +479,8 @@
     "Its default value is \\rawscm{\"\"}.")
    (finder:default-filters
     (case->
-     ((listof (list/p string? string?)) . -> . void?)
-     (-> (listof (list/p string? string?))))
+     ((listof (list/c string? string?)) . -> . void?)
+     (-> (listof (list/c string? string?))))
     ((filters) ())
     "This parameter controls the default extension for the framework's "
     "@flink finder:put-file"
@@ -1296,7 +1296,7 @@
      "section.")
     
     (scheme:get-color-prefs-table
-     (-> (listof (list/p symbol? (is-a?/c color%))))
+     (-> (listof (list/c symbol? (is-a?/c color%))))
      ()
      "Returns a table mapping from symbols (naming the categories that"
      "the online colorer uses for Scheme mode coloring) to their"
@@ -1390,7 +1390,7 @@
      "red green and blue for the second color, respectively.")
 
     (color-model:xyz->rgb
-     (number? number? number? . -> . (list/p number? number? number?))
+     (number? number? number? . -> . (list/c number? number? number?))
      (x y z)
      "Converts an XYZ-tuple (in the CIE XYZ colorspace) into a list of"
      "values representing an RGB-tuple.")
@@ -1437,10 +1437,13 @@
      "to set a callback for \\var{pref-name} that"
      "updates the style list when the preference changes.")
       
-    (color-prefs:add-preferences-panel 
+    (color-prefs:add-background-preferences-panel
      (-> void?)
      ()
-     "Adds in a preferences panel that configures colors (typically of text)")
+     "Adds a preferences panel that configures the background"
+     "color for"
+     "@mixin-link editor:basic-mixin %"
+     ".")
     (color-prefs:add-to-preferences-panel
      (string? ((is-a?/c vertical-panel%) . -> . void?) . -> . void?)
      (name func)

collects/framework/private/canvas.ss

@@ -16,7 +16,11 @@
       (define basic<%> (interface ((class->interface editor-canvas%))))
       (define basic-mixin
 	(mixin ((class->interface editor-canvas%)) (basic<%>)
-          (super-instantiate ())))
+          (super-new)
+          (define callback (lambda (p v) (set-canvas-background v)))
+          (inherit set-canvas-background)
+          (set-canvas-background (preferences:get 'framework:basic-canvas-background))
+          (preferences:add-callback 'framework:basic-canvas-background callback #t)))
       
       (define delegate<%> (interface (basic<%>)))
 

collects/framework/private/color-prefs.ss

@@ -9,14 +9,14 @@
   (provide color-prefs@)
   
   (define sc-color-syntax-interactively (string-constant color-syntax-interactively))
-  (define sc-syntax-coloring (string-constant syntax-coloring))
   (define sc-choose-color (string-constant syntax-coloring-choose-color))
   
   (define color-prefs@
     (unit/sig framework:color-prefs^
       (import [preferences : framework:preferences^]
               [editor : framework:editor^]
-              [panel : framework:panel^])
+              [panel : framework:panel^]
+              [canvas : framework:canvas^])
       
       (define standard-style-list-text% (editor:standard-style-list-mixin text%))
       
@@ -37,7 +37,7 @@
                                               style-name)])
                              (change-style style pos (+ pos offset) #f)))
                          (super-new))))
-        (define c (new editor-canvas%
+        (define c (new canvas:basic%
                        (parent hp)
                        (editor e)
                        (style '(hide-hscroll
@@ -188,87 +188,51 @@
              (send sd set-style-off 'italic)))
           sd))
       
-      
-      ;; prefs-panel-mapping : (union #f 
-      ;;                              hash-table[symbol -o> (is-a?/c vertical-panel)])
-      ;; #f => prefs panel not yet opened
-      ;; hash-table => prefs panel opened
-      ;;   the table maps from the name of the color preference to
-      ;;   the corresponding subpanel
-      (define prefs-panel-mapping #f)
-      
-      ;; prefs-panel-todo : (union #f (listof (cons string (vertical-panel -> void))))
-      ;; list => prefs panel not opened yet
-      ;; #f => prefs panel already opened.
-      (define prefs-panel-todo '())
-      
-      ;; prefs-panel-tab-panel : (union #f tab-panel)
-      (define prefs-panel-tab-panel #f)
-      ;; prefs-panel-single : (union #f single-panel%))
-      (define prefs-panel-single #f)
-      
-      (define prefs-panel-children '())
-      
-      ;; update-panel-single : -> void
-      ;; callback for the prefs-panel-tab-panel
-      (define (update-panel-single)
-        (let ([sel (send prefs-panel-tab-panel get-selection)])
-          (when sel
-            (let* ([label (list-ref prefs-panel-children sel)]
-                   [panel (hash-table-get prefs-panel-mapping (string->symbol label))])
-              (send prefs-panel-single active-child panel)))))
-      
-      ;; add-preferences-panel : -> void
-      ;; calls preferences:add-panel to add the coloring configuration panels
-      (define (add-preferences-panel)
+      (define (add-background-preferences-panel)
         (preferences:add-panel
-         (list sc-syntax-coloring)
+         (list (string-constant preferences-colors)
+               (string-constant background-color))
          (lambda (parent)
-           (set! prefs-panel-tab-panel (new tab-panel% 
-                                            (parent parent)
-                                            (choices (map car prefs-panel-todo))
-                                            (callback (lambda (x y) (update-panel-single)))))
-           (set! prefs-panel-single (new panel:single% (parent prefs-panel-tab-panel)))
-           (set! prefs-panel-mapping (make-hash-table))
-           (for-each
-            (lambda (pr)
-              (let* ([name (car pr)]
-                     [proc (cdr pr)]
-                     [panel (build-new-prefs-panel name)])
-                (proc panel)))
-            prefs-panel-todo)
-           (set! prefs-panel-todo #f)
-           prefs-panel-tab-panel)))
+           (letrec ([panel (new vertical-panel% (parent parent))]
+                    [hp (new horizontal-panel% (parent panel))]
+                    [canvas
+                     (new canvas%
+                          (parent hp)
+                          (paint-callback
+                           (lambda (c dc)
+                             (draw (preferences:get 'framework:basic-canvas-background)))))]
+                    [draw
+                     (lambda (clr)
+                       (let ([dc (send canvas get-dc)])
+                         (let-values ([(w h) (send canvas get-client-size)])
+                           (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
+                           (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
+                           (send dc draw-rectangle 0 0 w h))))]
+                    [button
+                     (new button% 
+                          (label (string-constant cs-change-color))
+                          (parent hp)
+                          (callback
+                           (lambda (x y)
+                             (let ([color (get-color-from-user
+                                           (string-constant choose-a-background-color)
+                                           (send hp get-top-level-window)
+                                           (preferences:get 'framework:basic-canvas-background))])
+                               (when color
+                                 (preferences:set 'framework:basic-canvas-background color))))))])
+             (preferences:add-callback
+              'framework:basic-canvas-background
+              (lambda (p v) (draw v)))
+             panel))))
       
       ;; add-to-preferences-panel : string (vertical-panel -> void) -> void
       (define (add-to-preferences-panel panel-name func)
-        (let ([key (string->symbol panel-name)])
-          (cond
-            [prefs-panel-todo
-             (let ([prev-pr (assq key prefs-panel-todo)])
-               (if prev-pr
-                   (let ([proc (cdr prev-pr)])
-                     (set-cdr! prev-pr 
-                               (lambda (parent)
-                                 (proc parent)
-                                 (func parent))))
-                   (set! prefs-panel-todo
-                         (append prefs-panel-todo (list (cons panel-name func))))))]
-            [else
-             (let ([prev-panel (hash-table-get prefs-panel-mapping key (lambda () #f))])
-               (cond
-                 [prev-panel (func prev-panel)]
-                 [else
-                  (send prefs-panel-tab-panel append panel-name)
-                  (let ([new-panel (build-new-prefs-panel panel-name)])
-                    (func new-panel))]))])))
-      
-      ;; build-new-prefs-panel : string -> horizontal-panel
-      (define (build-new-prefs-panel name)
-        (let ([panel (new vertical-panel% (parent prefs-panel-single))])
-          (set! prefs-panel-children (append prefs-panel-children (list name)))
-          (hash-table-put! prefs-panel-mapping (string->symbol name) panel)
-          panel))
+        (preferences:add-panel
+         (list (string-constant preferences-colors) panel-name)
+         (lambda (parent)
+           (let ([panel (new vertical-panel% (parent parent))])
+             (func panel)
+             panel))))
       
       ;; see docs
       (define (register-color-pref pref-name style-name color)

collects/framework/private/editor.ss

@@ -47,7 +47,7 @@
       (define basic-mixin
 	(mixin (editor<%>) (basic<%>)
 	  
-          (define/public (can-close?) #t)
+          (define/pubment (can-close?) (inner #t can-close?))
           (define/pubment (on-close) (inner (void) on-close))
           (define/public (close) (if (can-close?)
                                      (begin (on-close) #t)
@@ -386,33 +386,16 @@
       
       (define file<%> 
         (interface (-keymap<%>)
-          get-read-write?
           get-filename/untitled-name
           get-can-close-parent
           update-frame-filename))
       (define file-mixin
         (mixin (-keymap<%>) (file<%>)
-          (inherit
-            get-filename lock get-style-list 
-            is-modified? set-modified 
-            get-top-level-window)
+          (inherit get-filename lock get-style-list 
+                   is-modified? set-modified 
+                   get-top-level-window)
 
           (inherit get-canvases)
-          (define read-write? #t)
-          (define/public (get-read-write?) read-write?)
-          (define/private (check-lock)
-            (let* ([filename (get-filename)]
-                   [can-edit? (if (and filename
-                                       (file-exists? filename))
-                                  (and (member 'write (file-or-directory-permissions filename)) 
-                                       #t)
-                                  #t)])
-              (set! read-write? can-edit?)))
-          
-          (define/augment (can-insert? x y)
-            (and read-write? (inner #t can-insert? x y)))
-          (define/augment (can-delete? x y) (and read-write? (inner #t can-delete? x y)))
-          
           (define/public (update-frame-filename)
             (let* ([filename (get-filename)]
                    [name (if filename
@@ -437,15 +420,6 @@
                     (unless untitled-name
                       (set! untitled-name (gui-utils:next-untitled-name)))
                     untitled-name))))
-	  (define/augment (after-save-file success)
-            (when success
-              (check-lock))
-            (inner (void) after-save-file success))
-	   
-          (define/augment (after-load-file sucessful?)
-            (when sucessful?
-              (check-lock))
-            (inner (void) after-load-file sucessful?))
 
           (define/override set-filename
 	    (case-lambda
@@ -456,7 +430,7 @@
 		(update-frame-filename))]))
 
           (inherit save-file)
-          (define/override (can-close?)
+          (define/augment (can-close?)
             (let* ([user-allowed-or-not-modified
                     (or (not (is-modified?))
                         (case (gui-utils:unsaved-warning
@@ -469,7 +443,7 @@
                           [(save) (save-file)]
                           [else #f]))])
               (and user-allowed-or-not-modified
-                   (super can-close?))))
+                   (inner #t can-close?))))
           
           (define/public (get-can-close-parent) #f)
           

collects/framework/private/frame.ss

@@ -546,16 +546,15 @@
              'framework:show-status-line
              (lambda (p v)
                (update-info-visibility v)))]
-          [define memory-cleanup void] ;; only for CVSers and nightly build users; used with memory-text
+          (define memory-cleanup void) ;; only for CVSers and nightly build users; used with memory-text
 
-          [define/augment on-close
-            (lambda ()
-              (unregister-collecting-blit gc-canvas)
-              (close-panel-callback)
-              (memory-cleanup)
-	      (inner (void) on-close))]
+          (define/augment (on-close)
+            (unregister-collecting-blit gc-canvas)
+            (close-panel-callback)
+            (memory-cleanup)
+            (inner (void) on-close))
           
-          [define icon-currently-locked? 'uninit]
+          (define icon-currently-locked? 'uninit)
           (define/public (lock-status-changed)
             (let ([info-edit (get-info-editor)])
               (cond

collects/framework/private/main.ss

@@ -22,6 +22,18 @@
       
       (application-preferences-handler (lambda () (preferences:show-dialog)))
       
+      (preferences:set-default 'framework:basic-canvas-background
+                               (send the-color-database find-color "pink")
+                               (lambda (x) (is-a? x color%)))
+      (preferences:set-un/marshall 
+       'framework:basic-canvas-background
+       (lambda (clr) (list (send clr red) (send clr green) (send clr blue)))
+       (lambda (lst) (and (pair? lst)
+                          (pair? (cdr lst))
+                          (pair? (cddr lst))
+                          (null? (cdddr lst))
+                          (make-object color% (car lst) (cadr lst) (caddr lst)))))
+      
       (preferences:set-default 'framework:special-option-key #f boolean?)
       (preferences:add-callback 'framework:special-option-key (lambda (p v) (special-option-key v)))
       (special-option-key (preferences:get 'framework:special-option-key))

collects/framework/private/menu.ss

@@ -19,11 +19,10 @@
       (define can-restore-mixin
         (mixin (selectable-menu-item<%>) (can-restore<%>)
           (inherit set-shortcut get-shortcut)
-          [define saved-shortcut 'not-yet]
-          [define/public restore-keybinding
-            (lambda ()
-              (unless (eq? saved-shortcut 'not-yet)
-                (set-shortcut saved-shortcut)))]
+          (define saved-shortcut 'not-yet)
+          (define/public (restore-keybinding)
+            (unless (eq? saved-shortcut 'not-yet)
+              (set-shortcut saved-shortcut)))
           
           (super-instantiate ())
           (set! saved-shortcut (get-shortcut))

collects/framework/private/sig.ss

@@ -300,6 +300,7 @@
      searching<%>
      return<%>
      info<%>
+     file<%>
      clever-file-format<%>
      ports<%>
      
@@ -326,6 +327,7 @@
      searching-mixin
      return-mixin
      info-mixin
+     file-mixin
      clever-file-format-mixin
      ports-mixin))
   (define-signature framework:text-fun^
@@ -502,8 +504,8 @@
   (define-signature framework:color-prefs-fun^
     (register-color-pref
      add-to-preferences-panel
-     add-preferences-panel
-     build-color-selection-panel))
+     build-color-selection-panel
+     add-background-preferences-panel))
   (define-signature framework:color-prefs^
     ((open framework:color-prefs-class^)
      (open framework:color-prefs-fun^)))

collects/framework/private/text.ss

@@ -815,6 +815,42 @@ WARNING: printf is rebound in the body of the unit to always
             (inner (void) on-save-file name format))
           (super-instantiate ())))
       
+      
+      (define file<%>
+        (interface (editor:file<%> basic<%>)
+          get-read-write?))
+      
+      (define file-mixin
+        (mixin (editor:file<%> basic<%>) (file<%>)
+          (inherit get-filename)
+          (define read-write? #t)
+          (define/public (get-read-write?) read-write?)
+          (define/private (check-lock)
+            (let* ([filename (get-filename)]
+                   [can-edit? (if (and filename
+                                       (file-exists? filename))
+                                  (and (member 'write (file-or-directory-permissions filename)) 
+                                       #t)
+                                  #t)])
+              (set! read-write? can-edit?)))
+          
+          (define/augment (can-insert? x y)
+            (and read-write? (inner #t can-insert? x y)))
+          (define/augment (can-delete? x y) 
+            (and read-write? (inner #t can-delete? x y)))
+          
+          (define/augment (after-save-file success)
+            (when success
+              (check-lock))
+            (inner (void) after-save-file success))
+	   
+          (define/augment (after-load-file sucessful?)
+            (when sucessful?
+              (check-lock))
+            (inner (void) after-load-file sucessful?))
+          (super-new)))
+
+      
       (define ports<%>
         (interface ()
           delete/io
@@ -833,7 +869,8 @@ WARNING: printf is rebound in the body of the unit to always
           get-in-port
           get-out-port
           get-err-port
-          get-value-port))
+          get-value-port
+          after-io-insertion))
       
       (define-struct peeker (bytes skip-count pe resp-chan nack) (make-inspector))
       (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
@@ -1693,7 +1730,7 @@ WARNING: printf is rebound in the body of the unit to always
       (define -keymap% (editor:keymap-mixin standard-style-list%))
       (define return% (return-mixin -keymap%))
       (define autowrap% (editor:autowrap-mixin -keymap%))
-      (define file% (editor:file-mixin autowrap%))
+      (define file% (file-mixin (editor:file-mixin autowrap%)))
       (define clever-file-format% (clever-file-format-mixin file%))
       (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
       (define searching% (searching-mixin backup-autosave%))