From d08039585bc8363374b1ce57102336963aa96126 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 1 May 2008 12:43:43 +0000
Subject: [PATCH] moving to school

svn: r9561
---
 collects/framework/decorated-editor-snip.ss   | 456 +++++++++---------
 .../framework/decorated-editor-snip.scrbl     |  10 +
 .../scribblings/framework/framework.scrbl     |  12 +-
 3 files changed, 255 insertions(+), 223 deletions(-)
 create mode 100644 collects/scribblings/framework/decorated-editor-snip.scrbl

diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss
index 450b63021f..4644ebbc8b 100644
--- a/collects/framework/decorated-editor-snip.ss
+++ b/collects/framework/decorated-editor-snip.ss
@@ -1,229 +1,241 @@
+#lang scheme/base
 
-(module decorated-editor-snip mzscheme
-  (provide decorated-editor-snip%
-           decorated-editor-snipclass%
-           decorated-editor-snip-mixin)
+(require scheme/gui/base
+         scheme/class)
 
-  (require mzlib/class
-           mred
-           "preferences.ss")
-  
-  (define (decorated-editor-snip-mixin super%)
-    (class super%
-      
-      ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
-      ;; returns the bitmap to be shown in the top right corner.
-      (define/public (get-corner-bitmap) #f)
-      
-      ;; get-color : -> (union string (is-a?/c color%))
-      (define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black"))
-      
-      ;; get-menu : -> (union #f (is-a?/c popup-menu%))
-      ;; returns the popup menu that should appear
-      ;; when clicking in the top part of the snip.
-      (define/public (get-menu) #f)
+#;
+(provide editor-snip:decorated%
+         editor-snip:decorated-snipclass
+         editor-snip:decorated-editor-snip-mixin
+         decorated-editor-snip<%>)
 
-      ;; get-position : -> (union 'top-right 'left-top)
-      ;; returns the location of the image and the clickable
-      ;; region. 'top-right indicates top portion is clickable
-      ;; and icon on right. 'left-top means left portion is
-      ;; clickable and icon on top.
-      (define/public (get-position) 'top-right)
-      
-      [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)]
-      [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)]
-      
-      (inherit get-admin)
-      (define/override (on-event dc x y editorx editory evt)
-        (cond
-          [(eq? (send evt get-event-type) 'right-down)
-           (let ([sx (- (send evt get-x) x)]
-                 [sy (- (send evt get-y) y)]
-                 [bil (box 0)]
-                 [bit (box 0)]
-                 [bir (box 0)]
-                 [bib (box 0)]
-                 [bw (box 0)]
-                 [bh (box 0)]
-                 [bml (box 0)]
-                 [bmt (box 0)]
-                 [bmr (box 0)]
-                 [bmb (box 0)]
-                 [menu (get-menu)])
-             (get-extent dc x y bw bh #f #f #f #f)
-             (get-inset bil bit bir bib)
-             (get-margin bml bmt bmr bmb)
-             (let ([in-range
-                    (case (get-position)
-                      [(top-right)
-                       (and (<= 0 sx (unbox bw))
-                            (<= 0 sy (unbox bmt)))]
-                      [(left-top)
-                       (and (<= 0 sx (unbox bml))
-                            (<= 0 sy (unbox bh)))]
-                      [else #f])])
-               (cond
-                 [(and menu in-range)
-                  (let ([admin (get-admin)])
-                    (when admin
-                      (send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
-                  [else (super on-event dc x y editorx editory evt)])))]
-          [else
-           (super on-event dc x y editorx editory evt)]))
-      
-      (inherit get-extent get-inset)
-      (define/override (draw dc x y left top right bottom dx dy draw-caret)
-        (let ([bm (get-corner-bitmap)]
-              [bil (box 0)]
-              [bit (box 0)]
-              [bir (box 0)]
-              [bib (box 0)]
-              [bw (box 0)]
-              [bh (box 0)]
-              [bml (box 0)]
-              [bmt (box 0)]
-              [bmr (box 0)]
-              [bmb (box 0)])
-          (get-extent dc x y bw bh #f #f #f #f)
-          (get-inset bil bit bir bib)
-          (get-margin bml bmt bmr bmb)
-          (super draw dc x y left top right bottom dx dy draw-caret)
-          (let* ([old-pen (send dc get-pen)]
-                 [old-brush (send dc get-brush)]
-                 [white-on-black? (preferences:get 'framework:white-on-black?)])
-            
-            (send dc set-pen (send the-pen-list find-or-create-pen 
+(provide decorated-editor-snip%
+         decorated-editor-snipclass%
+         decorated-editor-snip-mixin
+         decorated-editor-snip<%>)
+
+(require "preferences.ss")
+
+(define decorated-editor-snip<%>
+  (interface ((class->interface editor-snip%))
+    get-corner-bitmap get-color get-menu get-position reset-min-sizes))
+
+(define decorated-editor-snip-mixin
+  (mixin ((class->interface editor-snip%)) (decorated-editor-snip<%>)
+    
+    ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%))
+    ;; returns the bitmap to be shown in the top right corner.
+    (define/public (get-corner-bitmap) #f)
+    
+    ;; get-color : -> (union string (is-a?/c color%))
+    (define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black"))
+    
+    ;; get-menu : -> (union #f (is-a?/c popup-menu%))
+    ;; returns the popup menu that should appear
+    ;; when clicking in the top part of the snip.
+    (define/public (get-menu) #f)
+    
+    ;; get-position : -> (union 'top-right 'left-top)
+    ;; returns the location of the image and the clickable
+    ;; region. 'top-right indicates top portion is clickable
+    ;; and icon on right. 'left-top means left portion is
+    ;; clickable and icon on top.
+    (define/public (get-position) 'top-right)
+    
+    [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)]
+    [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)]
+    
+    (inherit get-admin)
+    (define/override (on-event dc x y editorx editory evt)
+      (cond
+        [(eq? (send evt get-event-type) 'right-down)
+         (let ([sx (- (send evt get-x) x)]
+               [sy (- (send evt get-y) y)]
+               [bil (box 0)]
+               [bit (box 0)]
+               [bir (box 0)]
+               [bib (box 0)]
+               [bw (box 0)]
+               [bh (box 0)]
+               [bml (box 0)]
+               [bmt (box 0)]
+               [bmr (box 0)]
+               [bmb (box 0)]
+               [menu (get-menu)])
+           (get-extent dc x y bw bh #f #f #f #f)
+           (get-inset bil bit bir bib)
+           (get-margin bml bmt bmr bmb)
+           (let ([in-range
+                  (case (get-position)
+                    [(top-right)
+                     (and (<= 0 sx (unbox bw))
+                          (<= 0 sy (unbox bmt)))]
+                    [(left-top)
+                     (and (<= 0 sx (unbox bml))
+                          (<= 0 sy (unbox bh)))]
+                    [else #f])])
+             (cond
+               [(and menu in-range)
+                (let ([admin (get-admin)])
+                  (when admin
+                    (send admin popup-menu menu this (+ sx 1) (+ sy 1))))]
+               [else (super on-event dc x y editorx editory evt)])))]
+        [else
+         (super on-event dc x y editorx editory evt)]))
+    
+    (inherit get-extent get-inset)
+    (define/override (draw dc x y left top right bottom dx dy draw-caret)
+      (let ([bm (get-corner-bitmap)]
+            [bil (box 0)]
+            [bit (box 0)]
+            [bir (box 0)]
+            [bib (box 0)]
+            [bw (box 0)]
+            [bh (box 0)]
+            [bml (box 0)]
+            [bmt (box 0)]
+            [bmr (box 0)]
+            [bmb (box 0)])
+        (get-extent dc x y bw bh #f #f #f #f)
+        (get-inset bil bit bir bib)
+        (get-margin bml bmt bmr bmb)
+        (super draw dc x y left top right bottom dx dy draw-caret)
+        (let* ([old-pen (send dc get-pen)]
+               [old-brush (send dc get-brush)]
+               [white-on-black? (preferences:get 'framework:white-on-black?)])
+          
+          (send dc set-pen (send the-pen-list find-or-create-pen 
+                                 (if white-on-black? "black" "white")
+                                 1
+                                 'transparent))
+          (send dc set-brush (send the-brush-list find-or-create-brush 
                                    (if white-on-black? "black" "white")
-                                   1
-                                   'transparent))
-            (send dc set-brush (send the-brush-list find-or-create-brush 
-                                     (if white-on-black? "black" "white")
-                                     'solid))
-            (case (get-position)
-              [(top-right)
-               (send dc draw-rectangle 
-                     (+ x (unbox bml))
-                     (+ y (unbox bit))
-                     (max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
-                     (- (unbox bmt) (unbox bit)))]
-              [(left-top)
-               (send dc draw-rectangle 
-                     (+ x (unbox bil))
-                     (+ y (unbox bmt))
-                     (- (unbox bml) (unbox bil))
-                     (max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
-            
-            (send dc set-pen (send the-pen-list find-or-create-pen
-                                   (if white-on-black? "white" "black")
-                                   1
                                    'solid))
-            (send dc set-brush (send the-brush-list find-or-create-brush 
-                                     (if white-on-black? "white" "black")
-                                     'solid))
-
-            (when bm
-              (let ([bm-w (send bm get-width)]
-                    [bm-h (send bm get-height)])
-                (case (get-position)
-                  [(top-right)
-                   (send dc draw-bitmap
-                         bm
-                         (+ x (max 0
-                                   (- (unbox bw)
-                                      (unbox bmr)
-                                      bm-w)))
-                         ;; leave two pixels above and two below (see super-instantiate below)
-                         (+ y (unbox bit) 2))]
-                  [(left-top)
-                   (send dc draw-bitmap
-                         bm
-                         ;; leave two pixels left and two right (see super-instantiate below)
-                         (+ x (unbox bil) 2)
-                         (+ y (unbox bmt)))])))
-            
-            (send dc set-pen (get-pen))
-            (send dc set-brush (get-brush))
-            (send dc draw-rectangle
-                  (+ x (unbox bil))
-                  (+ y (unbox bit))
-                  (max 0 (- (unbox bw) (unbox bil) (unbox bir)))
-                  (max 0 (- (unbox bh) (unbox bit) (unbox bib))))
-            
-            (send dc set-pen old-pen)
-            (send dc set-brush old-brush))))
-      
-      (inherit set-min-width set-min-height get-margin)
-      (define/public (reset-min-sizes)
-        (let ([bm (get-corner-bitmap)])
+          (case (get-position)
+            [(top-right)
+             (send dc draw-rectangle 
+                   (+ x (unbox bml))
+                   (+ y (unbox bit))
+                   (max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
+                   (- (unbox bmt) (unbox bit)))]
+            [(left-top)
+             (send dc draw-rectangle 
+                   (+ x (unbox bil))
+                   (+ y (unbox bmt))
+                   (- (unbox bml) (unbox bil))
+                   (max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
+          
+          (send dc set-pen (send the-pen-list find-or-create-pen
+                                 (if white-on-black? "white" "black")
+                                 1
+                                 'solid))
+          (send dc set-brush (send the-brush-list find-or-create-brush 
+                                   (if white-on-black? "white" "black")
+                                   'solid))
+          
           (when bm
-            (case (get-position)
-              [(top-right)
-               (set-min-width (+ 4 (send bm get-width)))]
-              [(left-top)
-               (set-min-height (+ 4 (send bm get-height)))]))))
-      
-      (let ([top-margin 
-             (case (get-position)
-               [(top-right)
-                (+ 4 
-                   (let ([bm (get-corner-bitmap)])
-                     (if bm
-                         (send bm get-height)
-                         0)))]
-               [else 4])]
-            [left-margin
-             (case (get-position)
-               [(left-top)
-                (+ 4
-                   (let ([bm (get-corner-bitmap)])
-                     (if bm
-                         (send bm get-width)
-                         0)))]
-               [else 4])])
-        (super-new
-          (with-border? #f)
-          (top-margin top-margin)
-          (left-margin left-margin)))
-      
-      (inherit use-style-background)
-      (use-style-background #t)
-      
-      (reset-min-sizes)))
-  
-  (define decorated-editor-snip%
-    (class (decorated-editor-snip-mixin editor-snip%)
-      (inherit get-editor get-style)
-      
-      ;; make-snip : -> this%
-      ;; returns an instance of this class. used in the copy method
-      (define/public (make-snip) (make-object decorated-editor-snip%))
-      
-      ;; make-editor : -> editor<%>
-      ;; returns the editor to be used in this snip.
-      (define/public (make-editor) (make-object text%))
-      
-      (define/override write
-        (λ (stream-out)
-          (send (get-editor) write-to-file stream-out 0 'eof)))
+            (let ([bm-w (send bm get-width)]
+                  [bm-h (send bm get-height)])
+              (case (get-position)
+                [(top-right)
+                 (send dc draw-bitmap
+                       bm
+                       (+ x (max 0
+                                 (- (unbox bw)
+                                    (unbox bmr)
+                                    bm-w)))
+                       ;; leave two pixels above and two below (see super-instantiate below)
+                       (+ y (unbox bit) 2))]
+                [(left-top)
+                 (send dc draw-bitmap
+                       bm
+                       ;; leave two pixels left and two right (see super-instantiate below)
+                       (+ x (unbox bil) 2)
+                       (+ y (unbox bmt)))])))
+          
+          (send dc set-pen (get-pen))
+          (send dc set-brush (get-brush))
+          (send dc draw-rectangle
+                (+ x (unbox bil))
+                (+ y (unbox bit))
+                (max 0 (- (unbox bw) (unbox bil) (unbox bir)))
+                (max 0 (- (unbox bh) (unbox bit) (unbox bib))))
+          
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush))))
+    
+    (inherit set-min-width set-min-height get-margin)
+    (define/public (reset-min-sizes)
+      (let ([bm (get-corner-bitmap)])
+        (when bm
+          (case (get-position)
+            [(top-right)
+             (set-min-width (+ 4 (send bm get-width)))]
+            [(left-top)
+             (set-min-height (+ 4 (send bm get-height)))]))))
+    
+    (let ([top-margin 
+           (case (get-position)
+             [(top-right)
+              (+ 4 
+                 (let ([bm (get-corner-bitmap)])
+                   (if bm
+                       (send bm get-height)
+                       0)))]
+             [else 4])]
+          [left-margin
+           (case (get-position)
+             [(left-top)
+              (+ 4
+                 (let ([bm (get-corner-bitmap)])
+                   (if bm
+                       (send bm get-width)
+                       0)))]
+             [else 4])])
+      (super-new
+       (with-border? #f)
+       (top-margin top-margin)
+       (left-margin left-margin)))
+    
+    (inherit use-style-background)
+    (use-style-background #t)
+    
+    (reset-min-sizes)))
 
-      (define/override (copy)
-        (let ([snip (make-snip)])
-          (send snip set-editor (send (get-editor) copy-self))
-          (send snip set-style (get-style))
-          snip))
-      
-        (super-new
-          (editor (make-editor)))))
-  
-  (define decorated-editor-snipclass%
-    (class snip-class%
-      
-      ;; make-snip : stream-in -> (is-a?/c snip%)
-      ;; returns an unfilled version of the snip
-      (define/public (make-snip stream-in) (make-object decorated-editor-snip%))
-      
-      (define/override (read stream-in)
-        (let ([snip (make-snip stream-in)])
-          (send (send snip get-editor) read-from-file stream-in #f)
-          snip))
-      (super-new))))
+(define decorated-editor-snip%
+  (class (decorated-editor-snip-mixin editor-snip%)
+    (inherit get-editor get-style)
+    
+    ;; make-snip : -> this%
+    ;; returns an instance of this class. used in the copy method
+    (define/public (make-snip) (make-object decorated-editor-snip%))
+    
+    ;; make-editor : -> editor<%>
+    ;; returns the editor to be used in this snip.
+    (define/public (make-editor) (make-object text%))
+    
+    (define/override write
+      (λ (stream-out)
+        (send (get-editor) write-to-file stream-out 0 'eof)))
+    
+    (define/override (copy)
+      (let ([snip (make-snip)])
+        (send snip set-editor (send (get-editor) copy-self))
+        (send snip set-style (get-style))
+        snip))
+    
+    (super-new
+     (editor (make-editor)))))
+
+(define decorated-editor-snipclass%
+  (class snip-class%
+    
+    ;; make-snip : stream-in -> (is-a?/c snip%)
+    ;; returns an unfilled version of the snip
+    (define/public (make-snip stream-in) (make-object decorated-editor-snip%))
+    
+    (define/override (read stream-in)
+      (let ([snip (make-snip stream-in)])
+        (send (send snip get-editor) read-from-file stream-in #f)
+        snip))
+    (super-new)))
diff --git a/collects/scribblings/framework/decorated-editor-snip.scrbl b/collects/scribblings/framework/decorated-editor-snip.scrbl
new file mode 100644
index 0000000000..ec9362b530
--- /dev/null
+++ b/collects/scribblings/framework/decorated-editor-snip.scrbl
@@ -0,0 +1,10 @@
+#lang scribble/doc
+@(require scribble/manual)
+@(require (for-label framework))
+@(require (for-label scheme/gui))
+@title{Decorated Editor Snip}
+@(defmodule framework/decorated-editor-snip)
+
+@definterface[decorated-editor-snip<%> (editor-snip%)]{
+
+}
\ No newline at end of file
diff --git a/collects/scribblings/framework/framework.scrbl b/collects/scribblings/framework/framework.scrbl
index 84c3eec5dd..1f7becacc6 100644
--- a/collects/scribblings/framework/framework.scrbl
+++ b/collects/scribblings/framework/framework.scrbl
@@ -6,6 +6,10 @@
 @title{@bold{Framework}: PLT GUI Application Framework}
 @(defmodule framework)
 
+@itemize{@item{decorated editor snip isn't exported by framework/framework}}
+
+----------------------------------------------------------------------------------------------------
+
 The framework provides a number of mixins, classes and
 functions designed to help you build a complete application
 program on top of the @scheme[scheme/gui] library.
@@ -75,7 +79,13 @@ The precise set of exported names is:
 @scheme[preferences:set-default],
 @scheme[preferences:set-un/marshall], and
 @scheme[preferences:restore-defaults].
-}}
+}
+@item{@bold{Decorated Editor Snip}
+@scheme[(require framework/decorated-editor-snip)]
+
+This library exports an editor snipclass 
+}
+}
 
 @bold{Thanks}