diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss index 4644ebbc8b..5875dac677 100644 --- a/collects/framework/decorated-editor-snip.ss +++ b/collects/framework/decorated-editor-snip.ss @@ -1,241 +1,9 @@ #lang scheme/base -(require scheme/gui/base - scheme/class) +(require "private/decorated-editor-snip.ss") -#; -(provide editor-snip:decorated% - editor-snip:decorated-snipclass - editor-snip:decorated-editor-snip-mixin - decorated-editor-snip<%>) - -(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") - '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)]) - (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))) - - (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))) +(provide + (rename-out [editor-snip:decorated% decorated-editor-snip%]) + (rename-out [editor-snip:decorated-snipclass decorated-editor-snipclass%]) + (rename-out [editor-snip:decorated-mixin decorated-editor-snip-mixin]) + (rename-out [editor-snip:decorated<%> decorated-editor-snip<%>])) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index e1aef644de..39761f4598 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -11,12 +11,14 @@ (require framework/preferences framework/test framework/gui-utils - framework/decorated-editor-snip) + framework/decorated-editor-snip + framework/private/decorated-editor-snip) (provide (all-from-out framework/preferences framework/test framework/gui-utils - framework/decorated-editor-snip)) + framework/decorated-editor-snip + framework/private/decorated-editor-snip)) (require/doc scheme/base scribble/manual framework/private/mapdesc) @@ -424,9 +426,7 @@ (parent (finder:dialog-parent-parameter)))) @{This procedure queries the user for a single filename, using a platform-independent dialog box. Consider using - @scheme[finder:put-file] instead of this function. - - See section @secref{selecting-a-filename} for more information.}) + @scheme[finder:put-file] instead of this function.}) (proc-doc/names finder:common-get-file @@ -445,9 +445,7 @@ (parent #f))) @{This procedure queries the user for a single filename, using a platform-independent dialog box. Consider using - @scheme[finder:get-file] instead of this function. - - See section @secref{selecting-a-filename} for more information.}) + @scheme[finder:get-file] instead of this function.}) (proc-doc/names finder:std-put-file @@ -470,9 +468,7 @@ (parent (finder:dialog-parent-parameter)))) @{This procedure queries the user for a single filename, using a platform-dependent dialog box. Consider using - @scheme[finder:put-file] instead of this function. - - See section @secref{selecting-a-filename} for more information.}) + @scheme[finder:put-file] instead of this function.}) (proc-doc/names finder:std-get-file @@ -491,9 +487,7 @@ (parent #f))) @{This procedure queries the user for a single filename, using a platform-dependent dialog box. Consider using - @scheme[finder:get-file] instead of this function. - - See section @secref{selecting-a-filename} for more information.}) + @scheme[finder:get-file] instead of this function.}) (proc-doc/names finder:put-file @@ -557,9 +551,7 @@ (filter-msg "That filename does not have the right form.") (parent #f))) @{This procedure queries the user for a list of filenames, using a - platform-independent dialog box. - - See @secref{selecting-a-filename} for more information.}) + platform-independent dialog box.}) (proc-doc/names frame:setup-size-pref diff --git a/collects/framework/private/decorated-editor-snip.ss b/collects/framework/private/decorated-editor-snip.ss new file mode 100644 index 0000000000..f495ee35a6 --- /dev/null +++ b/collects/framework/private/decorated-editor-snip.ss @@ -0,0 +1,240 @@ +#lang scheme/base + +(require scheme/gui/base + scheme/class) + + +(provide editor-snip:decorated% + editor-snip:decorated-snipclass + editor-snip:decorated-mixin + editor-snip:decorated<%>) + +(require "../preferences.ss") + +(define editor-snip:decorated<%> + (interface ((class->interface editor-snip%)) + get-corner-bitmap + get-color + get-menu + get-position + reset-min-sizes)) + +(define editor-snip:decorated-mixin + (mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>) + + ;; 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") + '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)]) + (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 editor-snip:decorated% + (class (editor-snip:decorated-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 editor-snip:decorated%)) + + ;; 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 editor-snip:decorated-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 editor-snip:decorated%)) + + (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/framework/private/mode.ss b/collects/framework/private/mode.ss index 9b51226a54..1304dbea64 100644 --- a/collects/framework/private/mode.ss +++ b/collects/framework/private/mode.ss @@ -1,50 +1,60 @@ -#lang scheme/unit -(require scheme/class +#lang scheme/base + +(require (for-syntax scheme/base) + scheme/unit + scheme/class scheme/surrogate "sig.ss") -(import) -(export framework:mode^) +(provide mode@ surrogate-methods) -(define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>) - (surrogate - (augment (void) on-change ()) - (override on-char (event)) - (override on-default-char (event)) - (override on-default-event (event)) - (augment (void) on-display-size ()) - (augment (void) on-edit-sequence ()) - (override on-event (event)) - (override on-focus (on?)) - (augment (void) on-load-file (filename format)) - (override on-local-char (event)) - (override on-local-event (event)) - (override on-new-box (type)) - (override on-new-image-snip (filename kind relative-path? inline?)) - (override on-paint (before? dc left top right bottom dx dy draw-caret)) - (augment (void) on-save-file (filename format)) - (augment (void) on-snip-modified (snip modified?)) - - (augment (void) on-change-style (start len)) - (augment (void) on-delete (start len)) - (augment (void) on-insert (start len)) - (override on-new-string-snip ()) - (override on-new-tab-snip ()) - (augment (void) on-set-size-constraint ()) - - (augment (void) after-change-style (start len)) - (augment (void) after-delete (start len)) - (augment (void) after-insert (start len)) - (augment (void) after-set-position ()) - (augment (void) after-set-size-constraint ()) - (augment (void) after-edit-sequence ()) - (augment (void) after-load-file (success?)) - (augment (void) after-save-file (success?)) - - (augment #t can-change-style? (start len)) - (augment #t can-delete? (start len)) - (augment #t can-insert? (start len)) - (augment #t can-set-size-constraint? ()) - (override can-do-edit-operation? (op) (op recursive?)) - (augment #t can-load-file? (filename format)) - (augment #t can-save-file? (filename format)))) +(define-syntax (surrogate-methods stx) + (syntax-case stx () + [(_ m) + #'(m (augment (void) on-change ()) + (override on-char (event)) + (override on-default-char (event)) + (override on-default-event (event)) + (augment (void) on-display-size ()) + (augment (void) on-edit-sequence ()) + (override on-event (event)) + (override on-focus (on?)) + (augment (void) on-load-file (filename format)) + (override on-local-char (event)) + (override on-local-event (event)) + (override on-new-box (type)) + (override on-new-image-snip (filename kind relative-path? inline?)) + (override on-paint (before? dc left top right bottom dx dy draw-caret)) + (augment (void) on-save-file (filename format)) + (augment (void) on-snip-modified (snip modified?)) + + (augment (void) on-change-style (start len)) + (augment (void) on-delete (start len)) + (augment (void) on-insert (start len)) + (override on-new-string-snip ()) + (override on-new-tab-snip ()) + (augment (void) on-set-size-constraint ()) + + (augment (void) after-change-style (start len)) + (augment (void) after-delete (start len)) + (augment (void) after-insert (start len)) + (augment (void) after-set-position ()) + (augment (void) after-set-size-constraint ()) + (augment (void) after-edit-sequence ()) + (augment (void) after-load-file (success?)) + (augment (void) after-save-file (success?)) + + (augment #t can-change-style? (start len)) + (augment #t can-delete? (start len)) + (augment #t can-insert? (start len)) + (augment #t can-set-size-constraint? ()) + (override can-do-edit-operation? (op) (op recursive?)) + (augment #t can-load-file? (filename format)) + (augment #t can-save-file? (filename format)))])) + +(define-unit mode@ + (import) + (export framework:mode^) + + (define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>) + (surrogate-methods surrogate))) diff --git a/collects/scribblings/framework/comment-box.scrbl b/collects/scribblings/framework/comment-box.scrbl index 383b219eb6..0798850f39 100644 --- a/collects/scribblings/framework/comment-box.scrbl +++ b/collects/scribblings/framework/comment-box.scrbl @@ -4,7 +4,7 @@ @(require (for-label scheme/gui)) @title{Comment Box} -@defclass[comment-box:snip% decorated-editor-snip% (readable-snip<%>)]{ +@defclass[comment-box:snip% editor-snip:decorated% (readable-snip<%>)]{ This snip implements the comment boxes that you see in DrScheme. diff --git a/collects/scribblings/framework/decorated-editor-snip.scrbl b/collects/scribblings/framework/decorated-editor-snip.scrbl deleted file mode 100644 index ec9362b530..0000000000 --- a/collects/scribblings/framework/decorated-editor-snip.scrbl +++ /dev/null @@ -1,10 +0,0 @@ -#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/editor-snip.scrbl b/collects/scribblings/framework/editor-snip.scrbl new file mode 100644 index 0000000000..198d920f0c --- /dev/null +++ b/collects/scribblings/framework/editor-snip.scrbl @@ -0,0 +1,89 @@ +#lang scribble/doc +@(require scribble/manual) +@(require (for-label framework)) +@(require (for-label scheme/gui)) +@title[#:tag "editor-snip"]{Editor Snip} + +@definterface[editor-snip:decorated<%> (editor-snip%)]{ + @defmethod[(get-corner-bitmap) (or/c false/c (is-a?/c bitmap%))]{ + Returns a bitmap that is drawn in the upper-right corner of this snip. + } + @defmethod[(get-color) (or/c string? (is-a?/c color%))]{ + Returns the color used to draw the background part of the snip. + } + @defmethod[(get-menu) (or/c false/c (is-a?/c popup-menu%))] { + Returns a popup menu that is used when clicking on the top part of the snip. + } + @defmethod[(get-position) (symbols 'top-right 'left-top)] { + Returns the location of the image and the clickable + region. The symbol @scheme['top-right] indicates top portion is clickable + and icon on right. The symbol @scheme['left-top] means left portion is + clickable and icon on top. + } + @defmethod[(reset-min-sizes) void?] { + Sets the minimum sizes based on the result of + @method[editor-snip:decorated<%> get-corner-bitmap]. + } +} + + +@defmixin[editor-snip:decorated-mixin (editor-snip%) (editor-snip:decorated<%>)]{ + @defmethod[(get-corner-bitmap) (or/c false/c (is-a?/c bitmap%))]{ + Returns @scheme[#f]. + } + @defmethod[(get-color) (or/c string? (is-a?/c color%))]{ + Returns @schemeblock[ + (if (preferences:get 'framework:white-on-black?) + "white" + "black")] + } + @defmethod[(get-menu) (or/c false/c (is-a?/c popup-menu%))] { + Returns @scheme[#f]. + } + @defmethod[(get-position) (symbols 'top-right 'left-top)] { + Returns @scheme['top-right]. + } +} + +@defclass[editor-snip:decorated% (editor-snip:decorated-mixin editor-snip%) ()]{ + @defconstructor/auto-super[()]{ + Invokes the super constructor with the keyword @scheme[editor] as a call to + @method[editor-snip:decorated% make-editor]. + } + + @defmethod[(make-snip) (is-a?/c editor-snip:decorated%)]{ + This method should return an instance of the class it is invoked in. + If you create a subclass of this class, be sure to override this method and + have it create instances of the subclass. + } + @defmethod[(make-editor) (is-a?/c editor<%>)]{ + Creates an editor to be used in this snip. + } + + @defmethod[(copy) (is-a?/c editor-snip:decorated%)]{ + Uses the @method[editor-snip:decorated% make-editor] and + @method[editor-snip:decorated% make-snip] methods to create a + copy of this snip, as follows: + @schememod[ + (let ([snip (make-snip)]) + (send snip set-editor (send (get-editor) copy-self)) + (send snip set-style (get-style)) + snip)] + } +} + +@defclass[editor-snip:decorated-snipclass% snip-class% ()]{ + @defmethod[(make-snip [stream-in (is-a?/c editor-stream-in%)]) -editor-snip:decorated<%>]{ + Returns an instance of @scheme[editor-snip:decorated%]. + } + @defmethod[(read [stream-in (is-a?/c editor-stream-in%)]) editor-snip:decorated<%>]{ + Calls @method[editor-snip:decorated-snipclass% make-snip] to get an object and + then invokes its @scheme[editor<%>]'s @method[editor<%> read-from-file] method + in order to read a snip from @scheme[stream-in], eg: + @schemeblock[ + (let ([snip (make-snip stream-in)]) + (send (send snip get-editor) read-from-file stream-in #f) + snip) + ] + } +} diff --git a/collects/scribblings/framework/framework.scrbl b/collects/scribblings/framework/framework.scrbl index e182f8f9be..993906cafb 100644 --- a/collects/scribblings/framework/framework.scrbl +++ b/collects/scribblings/framework/framework.scrbl @@ -6,12 +6,6 @@ @title{@bold{Framework}: PLT GUI Application Framework} @(defmodule framework) -@bold{TODO} - -@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. @@ -58,13 +52,13 @@ This library provides all of the definitions beginning with @scheme[(require framework/gui-utils)] This libraries provides all of the definitions beginning - with \scheme{gui-utils:} described in this manual. + with @scheme[gui-utils:] described in this manual. } @item{ @bold{Preferences} @scheme[(require framework/preferences)] This library provides a subset of the names of the - \scheme|framework.ss| library, namely those for + @tt{framework.ss} library, namely those for manipulating preference settings and is designed to be used from mzscheme. @@ -85,7 +79,9 @@ The precise set of exported names is: @item{@bold{Decorated Editor Snip} @scheme[(require framework/decorated-editor-snip)] -This library exports an editor snipclass +This library is here for backwards compatibility. The +functionality in it has moved into the framework proper, in +the @secref["editor-snip"] section. } } @@ -105,6 +101,7 @@ their feedback and help. @include-section["color-prefs.scrbl"] @include-section["color.scrbl"] @include-section["comment-box.scrbl"] +@include-section["editor-snip.scrbl"] @include-section["editor.scrbl"] @include-section["exit.scrbl"] @include-section["finder.scrbl"] diff --git a/collects/scribblings/framework/mode-helpers.ss b/collects/scribblings/framework/mode-helpers.ss new file mode 100644 index 0000000000..c6ed06de04 --- /dev/null +++ b/collects/scribblings/framework/mode-helpers.ss @@ -0,0 +1,28 @@ +#reader scribble/reader +#lang scheme/base + +(provide spec->host-method spec->surrogate-method) +(require (for-template scribble/manual scheme/base)) +(require scheme/class) +(require (for-label framework)) + +(define (spec->host-method spec) + (syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y))) + [(override mtd (x ...) ...) + #'@defmethod*[(((mtd (x any/c) ...) any) ...)]{ + Delegates to the result of @method[mode:host-text<%> get-surrogate] if it is not @scheme[#f].}] + [(augment default mtd (x ...) ...) + #'@defmethod*[(((mtd (x any/c) ...) any) ...)]{ + Delegates to the result of @method[mode:host-text<%> get-surrogate] if it is not @scheme[#f].}])) + +(define (spec->surrogate-method spec) + (syntax-case* spec (override augment) (λ (x y) (eq? (syntax-e x) (syntax-e y))) + [(override method (x ...) ...) + #'@defmethod*[(((method (orig (is-a?/c text%)) (call-super (-> any)) (x any/c) ...) any) ...)]{ + Returns the result of invoking @scheme[call-super]. + }] + [(augment default method (x ...) ...) + #'@defmethod*[(((method (orig (is-a?/c text%)) (call-inner (-> any)) (x any/c) ...) any) ...)]{ + Returns the result of invoking @scheme[call-super]. + }])) + diff --git a/collects/scribblings/framework/mode.scrbl b/collects/scribblings/framework/mode.scrbl index f9f242be61..3d8461de8a 100644 --- a/collects/scribblings/framework/mode.scrbl +++ b/collects/scribblings/framework/mode.scrbl @@ -2,7 +2,45 @@ @(require scribble/manual scribble/extract) @(require (for-label framework)) @(require (for-label scheme/gui)) +@(require (for-syntax "mode-helpers.ss")) @title{Mode} +@(begin +(require framework/private/mode (for-syntax scheme/base)) + +(define-syntax (docs stx) + (syntax-case stx () + [(_ spec ...) + #`(begin + @definterface[mode:surrogate-text<%> ()]{ + @defmethod[(on-enable-surrogate) any]{ + Called by @method[mode:host-text<%> set-surrogate] to + notify the surrogate that it has just become active. + } + @defmethod[(on-disable-surrogate) any]{ + Called by @method[mode:host-text<%> set-surrogate] to + notify the surrogate that it has just been disabled. + } + } + @defclass[mode:surrogate-text% object% (mode:surrogate-text<%>)]{ + @#,@(map spec->surrogate-method (syntax->list #'(spec ...))) + } + @definterface[mode:host-text<%> ()]{ + @defmethod[(get-surrogate) + (or/c false/c (is-a?/c mode:surrogate-text<%>))]{ + Returns the currently active surrogate. + } + @defmethod[(set-surrogate + [surrogate (or/c false/c (is-a?/c mode:surrogate-text<%>))]) + void?]{ + Sets the current surrogate to @scheme[surrogate]. + } + } + @defmixin[mode:host-text-mixin () (mode:host-text<%>)]{ + @#,@(map spec->host-method (syntax->list #'(spec ...))) +})])) + +(surrogate-methods docs) +) @(include-extracted (lib "main.ss" "framework") #rx"^mode:")