diff --git a/collects/framework/gui-utils.rkt b/collects/framework/gui-utils.rkt index c50be8fb..7c89d95c 100644 --- a/collects/framework/gui-utils.rkt +++ b/collects/framework/gui-utils.rkt @@ -294,34 +294,38 @@ (provide/doc (proc-doc gui-utils:trim-string - (->d ([str string?][size (and/c number? positive?)]) + (->i ([str string?] + [size (and/c number? positive?)]) () - [_ (and/c string? - (λ (str) - ((string-length str) . <= . size)))]) + [res (size) + (and/c string? + (λ (str) + ((string-length str) . <= . size)))]) @{Constructs a string whose size is less than @scheme[size] by trimming the @scheme[str] and inserting an ellispses into it.}) (proc-doc gui-utils:quote-literal-label - (->d ([str string?]) + (->i ([str string?]) () - [_ (and/c string? - (lambda (str) - ((string-length str) . <= . 200)))]) + [res (str) + (and/c string? + (lambda (str) + ((string-length str) . <= . 200)))]) @{Constructs a string whose ampersand characters are escaped; the label is also trimmed to <= 200 characters.}) (proc-doc gui-utils:format-literal-label - (->d ([str string?]) + (->i ([str string?]) () - #:rest rest (listof any/c) - [_ (and/c string? - (lambda (str) - ((string-length str) . <= . 200)))]) + #:rest [rest (listof any/c)] + [res (str) + (and/c string? + (lambda (str) + ((string-length str) . <= . 200)))]) @{Formats a string whose ampersand characters are mk-escaped; the label is also trimmed to <= 200 mk-characters.}) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 7568e710..e7d90cb3 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -54,269 +54,265 @@ (link standard-mred@ framework@)) (provide/doc - - (proc-doc/names + + (proc-doc/names text:range? (-> any/c boolean?) (arg) @{Determines if @scheme[arg] is an instance of the @tt{range} struct.}) - + (proc-doc/names text:range-start (-> text:range? exact-nonnegative-integer?) (range) @{Returns the start position of the range.}) + (proc-doc/names text:range-end (-> text:range? exact-nonnegative-integer?) (range) @{Returns the end position of the range.}) + (proc-doc/names text:range-caret-space? (-> text:range? boolean?) (range) - @{Returns a boolean indicating where the caret-space in the range goes. See also @method[text:basic<%> highlight-range].}) + @{Returns a boolean indicating where the caret-space in the range goes. + See also @method[text:basic<%> highlight-range].}) + (proc-doc/names text:range-style (-> text:range? exact-nonnegative-integer?) (range) - @{Returns the style of the range. See also @method[text:basic<%> highlight-range].}) + @{Returns the style of the range. + See also @method[text:basic<%> highlight-range].}) + (proc-doc/names text:range-color (-> text:range? (or/c string? (is-a?/c color%))) (range) @{Returns the color of the highlighted range.}) - + (parameter-doc text:autocomplete-append-after (parameter/c string?) suffix @{A string that is inserted after a completion is inserted by a - @scheme[text:autocomplete] instance. - - Defaults to @scheme[""].}) - + @scheme[text:autocomplete] instance. + + Defaults to @scheme[""].}) + (parameter-doc text:autocomplete-limit (parameter/c (and/c integer? exact? positive?)) count - @{Controls the number of completions visible at a time in the menu - produced by @scheme[text:autocomplete] instances. - - Defaults to 15.}) - + @{Controls the number of completions visible at a time in the menu produced + by @scheme[text:autocomplete] instances. + + Defaults to 15.}) + (proc-doc/names text:get-completions/manuals (-> (or/c false/c (listof symbol?)) (listof string?)) (manuals) - @{Returns the list of keywords for the manuals from @scheme[manuals] - by extracting all of the documented exports of the manuals. The - symbols are meant to be module paths, eg the quoted - form of the argument to @scheme[require]. + @{Returns the list of keywords for the manuals from @scheme[manuals] by + extracting all of the documented exports of the manuals. The symbols are + meant to be module paths, e.g., the quoted form of the argument to + @scheme[require]. + + If @scheme[manuals] is false, then all of the documented names are used.}) - If @scheme[manuals] is false, - then all of the documented names are used.}) - (proc-doc/names text:lookup-port-name (-> symbol? (or/c (is-a?/c editor:basic<%>) false/c)) (manuals) - @{Returns the editor instance whose port-name matches the given symbol. If no - editor can be found, then returns @scheme[false].}) - + @{Returns the editor instance whose port-name matches the given symbol. + If no editor can be found, then returns @scheme[false].}) + (proc-doc/names number-snip:make-repeating-decimal-snip (number? boolean? . -> . (is-a?/c snip%)) (num show-prefix?) - @{Makes a number snip that shows the decimal expansion for - @scheme[number] The boolean indicates if a @litchar{#e} prefix - appears on the number. - - See also @scheme[number-snip:make-fraction-snip].}) - + @{Makes a number snip that shows the decimal expansion for @scheme[number]. + The boolean indicates if a @litchar{#e} prefix appears on the number. + + See also @scheme[number-snip:make-fraction-snip].}) + (proc-doc/names number-snip:make-fraction-snip (number? boolean? . -> . (is-a?/c snip%)) (num show-prefix-in-decimal-view?) @{Makes a number snip that shows a fractional view of @scheme[number]. - The boolean indicates if a @litchar{#e} prefix appears on the - number, when shown in the decimal state. - - See also @scheme[number-snip:make-repeating-decimal-snip].}) - + The boolean indicates if a @litchar{#e} prefix appears on the number, when + shown in the decimal state. + + See also @scheme[number-snip:make-repeating-decimal-snip].}) + (proc-doc/names version:add-spec (any/c any/c . -> . void?) (spec revision) - @{These two values are appended to the version string. @scheme[write] - is used to transform them to strings. For example: - - @scheme[(version:add-spec 's 1)] - - in version 205 will make the version string be @litchar{205s1}. The - symbols @scheme['f] and @scheme['d] are used internally for - framework and drscheme revisions.}) - + @{The two values are appended to the version string. @scheme[write] is used + to transform them to strings. For example: + + @scheme[(version:add-spec 's 1)] + + in version 205 will make the version string be @litchar{205s1}. The + symbols @scheme['f] and @scheme['d] were used internally for framework and + drscheme revisions in the past.}) + (proc-doc/names version:version (-> string?) () - @{This function returns a string describing the version of this - application. See also @scheme[version:add-spec].}) - + @{This function returns a string describing the version of this application. + See also @scheme[version:add-spec].}) + (parameter-doc application:current-app-name (parameter/c string?) name - @{This is a parameter specifying the name of the current - application. It is used in the help menu - (see @scheme[frame:standard-menus%]) and in frame titles - (see @scheme[frame:editor%]). - The first case in the case-lambda returns the current name, and the - second case in the case-lambda sets the name of the application to - @scheme[name].}) - + @{This is a parameter specifying the name of the current application. It is + used in the help menu (see @scheme[frame:standard-menus%]) and in frame + titles (see @scheme[frame:editor%]). The first case in the case-lambda + returns the current name, and the second case in the case-lambda sets the + name of the application to @scheme[name].}) + (proc-doc/names preferences:put-preferences/gui (-> (listof symbol?) (listof any/c) any) (name-list val-list) - @{Like @scheme[put-preferences], but has more sophisticated error - handling. In particular, it - @itemize[ - @item{waits for three consecutive failures before informing the - user} - @item{gives the user the opportunity to ``steal'' the lockfile - after the third failure, and} - @item{when failures occur, it remembers what its arguments were - and if any preference save eventually succeeds, all of the - past failures are also written at that point.}]}) - + @{Like @scheme[put-preferences], but has more sophisticated error handling. + In particular, it + @itemize[ + @item{waits for three consecutive failures before informing the user} + @item{gives the user the opportunity to ``steal'' the lockfile after the + third failure, and} + @item{when failures occur, it remembers what its arguments were and if + any preference save eventually succeeds, all of the past failures + are also written at that point.}]}) + (proc-doc/names preferences:add-panel (-> (or/c string? (cons/c string? (listof string?))) - (->d ([parent (is-a?/c area-container-window<%>)]) + (->i ([parent (is-a?/c area-container-window<%>)]) () - [_ - (let ([old-children (send parent get-children)]) - (and/c (is-a?/c area-container-window<%>) - (λ (child) - (andmap eq? - (append old-children (list child)) - (send parent get-children)))))]) + [_ (parent) + (let ([old-children (send parent get-children)]) + (and/c (is-a?/c area-container-window<%>) + (λ (child) + (andmap eq? + (append old-children (list child)) + (send parent get-children)))))]) void?) (labels f) - @{@scheme[preferences:add-preference-panel] adds the result of - @scheme[f] with name @scheme[labels] to the preferences dialog box. - - The labels determine where this preference panel is placed in the - dialog. If the list is just one string, the preferences panel is - placed at the top level of the dialog. If there are more strings, a - hierarchy of nested panels is created and the new panel is added at - the end. If multiple calls to - @scheme[preferences:add-preference-panel] pass the same prefix of - strings, those panels are placed in the same children. - - When the preference dialog is opened for the first time, the - function @scheme[f] is called with a panel, and @scheme[f] is - expected to add a new child panel to it and add whatever preferences - configuration controls it wants to that panel. Then, @scheme[f]'s - should return the panel it added.}) - + @{@scheme[preferences:add-preference-panel] adds the result of @scheme[f] + with name @scheme[labels] to the preferences dialog box. + + The labels determine where this preference panel is placed in the dialog. + If the list is just one string, the preferences panel is placed at the top + level of the dialog. If there are more strings, a hierarchy of nested + panels is created and the new panel is added at the end. If multiple calls + to @scheme[preferences:add-preference-panel] pass the same prefix of + strings, those panels are placed in the same children. + + When the preference dialog is opened for the first time, the function + @scheme[f] is called with a panel, and @scheme[f] is expected to add a new + child panel to it and add whatever preferences configuration controls it + wants to that panel. Then, @scheme[f]'s should return the panel it added.}) + (proc-doc/names preferences:add-editor-checkbox-panel (-> void?) () - @{Adds a preferences panel for configuring options related to - editing.}) - + @{Adds a preferences panel for configuring options related to editing.}) + (proc-doc/names preferences:add-general-checkbox-panel (-> void?) () @{Adds a catch-all preferences panel for options.}) - + (proc-doc/names preferences:add-warnings-checkbox-panel (-> void?) () - @{Adds a preferences panel for configuring options relating to - warnings.}) - + @{Adds a preferences panel for configuring options relating to warnings.}) + (proc-doc/names preferences:add-scheme-checkbox-panel (-> void?) () - @{Adds a preferences panel for configuring options related to - Racket.}) - + @{Adds a preferences panel for configuring options related to Racket.}) + (proc-doc/names preferences:add-to-warnings-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Misc. panel to add new children to the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the Misc. panel to add new children to the panel.}) + (proc-doc/names preferences:add-to-scheme-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Racket preferences panel to add new children to - the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the Racket preferences panel to add new children to the + panel.}) + (proc-doc/names preferences:add-to-editor-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the editor preferences panel to add new children to - the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the editor preferences panel to add new children to the + panel.}) + (proc-doc/names preferences:add-to-general-checkbox-panel (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) - @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the general preferences panel to add new children to - the panel.}) - + @{Saves @scheme[proc] until the preferences panel is created, when it is + called with the general preferences panel to add new children to the + panel.}) + (proc-doc/names preferences:add-font-panel (-> void?) () @{Adds a font selection preferences panel to the preferences dialog.}) - + (proc-doc/names preferences:show-dialog (-> void?) () @{Shows the preferences dialog.}) - + (proc-doc/names preferences:hide-dialog (-> void?) () @{Hides the preferences dialog.}) - + (proc-doc/names preferences:add-on-close-dialog-callback ((-> void?) . -> . void?) (cb) @{Registers @scheme[cb]. Next time the user clicks the OK button the - preferences dialog, all of the @scheme[cb] functions are called, - assuming that each of the callbacks passed to - @scheme[preferences:add-can-close-dialog-callback] succeed.}) - + preferences dialog, all of the @scheme[cb] functions are called, assuming + that each of the callbacks passed to + @scheme[preferences:add-can-close-dialog-callback] succeed.}) + (proc-doc/names preferences:add-can-close-dialog-callback ((-> boolean?) . -> . void?) (cb) @{Registers @scheme[cb]. Next time the user clicks the OK button the - preferences dialog, all of the @scheme[cb] functions are called. If - any of them return @scheme[#f], the dialog is not closed. - - See also @scheme[preferences:add-on-close-dialog-callback].}) - + preferences dialog, all of the @scheme[cb] functions are called. If any of + them return @scheme[#f], the dialog is not closed. + + See also @scheme[preferences:add-on-close-dialog-callback].}) + (proc-doc/names autosave:register ((and/c (is-a?/c autosave:autosavable<%>) @@ -324,138 +320,136 @@ . -> . void?) (obj) - @{Adds @scheme[obj] to the list of objects to be autosaved. When it - is time to autosave, the @scheme[do-autosave] method of the object - is called. This method is responsible for performing the autosave. - - There is no need to de-register an object because the autosaver - keeps a ``weak'' pointer to the object; i.e., the autosaver does not - keep an object from garbage collection.}) - + @{Adds @scheme[obj] to the list of objects to be autosaved. When it is time + to autosave, the @scheme[do-autosave] method of the object is called. This + method is responsible for performing the autosave. + + There is no need to de-register an object because the autosaver keeps a + ``weak'' pointer to the object; i.e., the autosaver does not keep an object + from garbage collection.}) + (proc-doc/names autosave:restore-autosave-files/gui (-> void?) () - @{Opens a GUI to ask the user about recovering any autosave files left - around from crashes and things. - - This function doesn't return until the user has finished restoring - the autosave files. (It uses yield to handle events however.)}) - + @{Opens a GUI to ask the user about recovering any autosave files left around + from crashes and things. + + This function doesn't return until the user has finished restoring the + autosave files. (It uses yield to handle events however.)}) + (proc-doc/names exit:exiting? (-> boolean?) () - @{Returns @scheme[#t] to indicate that an exit operation is taking - place. Does not indicate that the app will actually exit, since the - user may cancel the exit. - - See also @scheme[exit:insert-on-callback] and - @scheme[exit:insert-can?-callback].}) - + @{Returns @scheme[#t] to indicate that an exit operation is taking place. + Does not indicate that the app will actually exit, since the user may + cancel the exit. + + See also @scheme[exit:insert-on-callback] and + @scheme[exit:insert-can?-callback].}) + (proc-doc/names exit:set-exiting (boolean? . -> . void?) (exiting?) @{Sets a flag that affects the result of @scheme[exit:exiting?].}) - + (proc-doc/names exit:insert-on-callback ((-> void?) . -> . (-> void?)) (callback) - @{Adds a callback to be called when exiting. This callback must not - fail. If a callback should stop an exit from happening, use - @scheme[exit:insert-can?-callback].}) - + @{Adds a callback to be called when exiting. This callback must not fail. + If a callback should stop an exit from happening, use + @scheme[exit:insert-can?-callback].}) + (proc-doc/names exit:insert-can?-callback ((-> boolean?) . -> . (-> void?)) (callback) - @{Use this function to add a callback that determines if an attempted - exit can proceed. This callback should not clean up any state, - since another callback may veto the exit. Use - @scheme[exit:insert-on-callback] for callbacks that clean up - state.}) - + @{Use this function to add a callback that determines if an attempted exit + can proceed. This callback should not clean up any state, since another + callback may veto the exit. Use @scheme[exit:insert-on-callback] for + callbacks that clean up state.}) + (proc-doc/names exit:can-exit? (-> boolean?) () @{Calls the ``can-callbacks'' and returns their results. See - @scheme[exit:insert-can?-callback] for more information.}) - + @scheme[exit:insert-can?-callback] for more information.}) + (proc-doc/names exit:on-exit (-> void?) () - @{Calls the ``on-callbacks''. See @scheme[exit:insert-on-callback] - for more information.}) - + @{Calls the ``on-callbacks''. See @scheme[exit:insert-on-callback] for more + information.}) + (proc-doc/names exit:exit (-> any) () @{@scheme[exit:exit] performs four actions: - @itemize[ - @item{sets the result of the @scheme[exit:exiting?] function to - @scheme[#t].} - @item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if - none of the ``can?'' callbacks return @scheme[#f],} - @item{invokes @scheme[exit:on-exit] and then} - @item{queues a callback that calls @scheme[exit] - (a mzscheme procedure) and (if @scheme[exit] returns) sets the result of - @scheme[exit:exiting?] back to @scheme[#t].}]}) - + @itemize[ + @item{sets the result of the @scheme[exit:exiting?] function to + @scheme[#t].} + @item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if none of + the ``can?'' callbacks return @scheme[#f],} + @item{invokes @scheme[exit:on-exit] and then} + @item{queues a callback that calls @scheme[exit] (a racket procedure) + and (if @scheme[exit] returns) sets the result of + @scheme[exit:exiting?] back to @scheme[#t].}]}) + (proc-doc/names exit:user-oks-exit (-> boolean?) () - @{Opens a dialog that queries the user about exiting. Returns the - user's decision.}) - + @{Opens a dialog that queries the user about exiting. Returns the user's + decision.}) + (proc-doc/names path-utils:generate-autosave-name (string? . -> . string?) (filename) @{Generates a name for an autosave file from @scheme[filename].}) - + (proc-doc/names path-utils:generate-backup-name (path? . -> . path?) (filename) @{Generates a name for an backup file from @scheme[filename].}) - + (parameter-doc finder:dialog-parent-parameter (parameter/c (or/c false/c (is-a?/c dialog%) (is-a?/c frame%))) parent @{This parameter determines the parent of the dialogs created by - @scheme[finder:get-file], @scheme[finder:put-file], - @scheme[finder:common-get-file], @scheme[finder:common-put-file], - @scheme[finder:common-get-file-list], @scheme[finder:std-get-file], - and @scheme[finder:std-put-file].}) - + @scheme[finder:get-file], @scheme[finder:put-file], + @scheme[finder:common-get-file], @scheme[finder:common-put-file], + @scheme[finder:common-get-file-list], @scheme[finder:std-get-file], + and @scheme[finder:std-put-file].}) + (parameter-doc finder:default-extension (parameter/c string?) extension @{This parameter controls the default extension for the framework's - @scheme[finder:put-file] dialog. Its value gets passed as the - @scheme[default-extension] argument to @scheme[put-file]. - - Its default value is @scheme[""].}) - + @scheme[finder:put-file] dialog. Its value gets passed as the + @scheme[default-extension] argument to @scheme[put-file]. + + Its default value is @scheme[""].}) + (parameter-doc finder:default-filters (parameter/c (listof (list/c string? string?))) filters - @{ - This parameter controls the default filters for the framework's - @scheme[finder:put-file] dialog. Its value gets passed as the - @scheme[default-filters] argument to @scheme[put-file]. - - Its default value is @scheme['(("Any" "*.*"))].}) - + @{This parameter controls the default filters for the framework's + @scheme[finder:put-file] dialog. Its value gets passed as the + @scheme[default-filters] argument to @scheme[put-file]. + + Its default value is @scheme['(("Any" "*.*"))].}) + (proc-doc/names finder:common-put-file (->* () @@ -476,9 +470,9 @@ (filter-msg "That filename does not have the right form.") (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.}) - + platform-independent dialog box. Consider using @scheme[finder:put-file] + instead of this function.}) + (proc-doc/names finder:common-get-file (->* () @@ -495,9 +489,9 @@ (filter-msg "That filename does not have the right form.") (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.}) - + platform-independent dialog box. Consider using + @scheme[finder:get-file] instead of this function.}) + (proc-doc/names finder:std-put-file (->* () @@ -518,9 +512,9 @@ (filter-msg "That filename does not have the right form.") (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.}) - + platform-dependent dialog box. Consider using @scheme[finder:put-file] + instead of this function.}) + (proc-doc/names finder:std-get-file (->* () @@ -537,9 +531,9 @@ (filter-msg "That filename does not have the right form.") (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.}) - + platform-dependent dialog box. Consider using @scheme[finder:get-file] + instead of this function.}) + (proc-doc/names finder:put-file (->* () @@ -560,11 +554,11 @@ (filter-msg "That filename does not have the right form.") (parent (finder:dialog-parent-parameter)))) @{Queries the user for a filename. - - If the result of @scheme[(preferences:get 'framework:file-dialogs)] - is @scheme['std] this calls @scheme[finder:std-put-file], and if it - is @scheme['common], @scheme[finder:common-put-file] is called.}) - + + If the result of @scheme[(preferences:get 'framework:file-dialogs)] is + @scheme['std] this calls @scheme[finder:std-put-file], and if it is + @scheme['common], @scheme[finder:common-put-file] is called.}) + (proc-doc/names finder:get-file (->* () @@ -581,11 +575,11 @@ (filter-msg "That filename does not have the right form.") (parent #f))) @{Queries the user for a filename. - - If the result of @scheme[(preferences:get 'framework:file-dialogs)] - is @scheme['std] this calls @scheme[finder:std-get-file], and if it - is @scheme['common], @scheme[finder:common-get-file] is called.}) - + + If the result of @scheme[(preferences:get 'framework:file-dialogs)] is + @scheme['std] this calls @scheme[finder:std-get-file], and if it is + @scheme['common], @scheme[finder:common-get-file] is called.}) + (proc-doc/names finder:common-get-file-list (->* () @@ -602,17 +596,17 @@ (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.}) - + platform-independent dialog box.}) + (proc-doc/names frame:setup-size-pref (symbol? number? number? . -> . void) (size-pref-sym width height) @{Initializes a preference for the @scheme[frame:size-pref] mixin. - - The first argument should be the preferences symbol, and the second - an third should be the default width and height, respectively.}) - + + The first argument should be the preferences symbol, and the second and + third should be the default width and height, respectively.}) + (proc-doc/names frame:add-snip-menu-items (->* ((is-a?/c menu%) (subclass?/c menu-item%)) @@ -620,31 +614,31 @@ void?) ((menu menu-item%) ((func void))) - @{Inserts three menu items into @scheme[menu], one that inserts a text - box, one that inserts a pasteboard box, and one that inserts an - image into the currently focused editor (if there is one). Uses - @scheme[menu-item%] as the class for the menu items. - - Calls @scheme[func] right after inserting each menu item.}) - + @{Inserts three menu items into @scheme[menu], one that inserts a text box, + one that inserts a pasteboard box, and one that inserts an image into the + currently focused editor (if there is one). Uses @scheme[menu-item%] as + the class for the menu items. + + Calls @scheme[func] right after inserting each menu item.}) + (proc-doc/names frame:reorder-menus ((is-a?/c frame%) . -> . void?) (frame) - @{Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' - menus to the front of the menubar and moves the ``Windows'' and - ``Help'' menus to the end of the menubar. - - This is useful in conjunction with the frame classes. After - instantiating the class and adding ones own menus, the menus will be - mis-ordered. This function fixes them up.}) - + @{Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' menus + to the front of the menubar and moves the ``Windows'' and ``Help'' menus to + the end of the menubar. + + This is useful in conjunction with the frame classes. After instantiating + the class and adding ones own menus, the menus will be mis-ordered. This + function fixes them up.}) + (proc-doc/names frame:remove-empty-menus ((is-a?/c frame%) . -> . void?) (frame) @{Removes empty menus in a frame.}) - + (parameter-doc frame:current-icon (parameter/c (or/c #f @@ -654,77 +648,78 @@ icon-spec @{The value of this parameter is used by the initialization code of @scheme[frame:basic-mixin]. - @itemize[@item{If it is @scheme[#f], then its value is - ignored.} - @item{It it is a @scheme[bitmap%], then the @method[frame% set-icon] is called - with the bitmap, the result of invoking the @scheme[bitmap% get-loaded-mask] method, - and @scheme['both].} - @item{If it is a pair of bitmaps, then the @method[frame% set-icon] - method is invoked twice, once with each bitmap in the pair. The first bitmap - is passed (along with the result of its @scheme[bitmap% get-loaded-mask]) - and @scheme['small], and then the second bitmap is passed - (also along with the result of its @scheme[bitmap% get-loaded-mask]) and @scheme['large].}] + @itemize[ + @item{If it is @scheme[#f], then its value is ignored.} + @item{If it is a @scheme[bitmap%], then the @method[frame% set-icon] is + called with the bitmap, the result of invoking the + @scheme[bitmap% get-loaded-mask] method, and @scheme['both].} + @item{If it is a pair of bitmaps, then the @method[frame% set-icon] + method is invoked twice, once with each bitmap in the pair. The + first bitmap is passed (along with the result of its + @scheme[bitmap% get-loaded-mask]) and @scheme['small], and then the + second bitmap is passed (also along with the result of its + @scheme[bitmap% get-loaded-mask]) and @scheme['large].}] Defaults to @scheme[#f].}) - + (proc-doc/names group:get-the-frame-group (-> (is-a?/c group:%)) () @{This returns the frame group.}) - + (proc-doc/names group:on-close-action (-> void?) () @{See also @scheme[group:can-close-check]. - - Call this function from the @method[top-level-window<%> can-close?] - callback of a frame in order for the group to properly close the - application.}) - + + Call this function from the @method[top-level-window<%> can-close?] + callback of a frame in order for the group to properly close the + application.}) + (proc-doc/names group:can-close-check (-> boolean?) () @{See also @scheme[group:on-close-action]. - - Call this function from the @method[top-level-window<%> can-close?] - callback of a frame in order for the group to properly close the - application.}) - + + Call this function from the @method[top-level-window<%> can-close?] + callback of a frame in order for the group to properly close the + application.}) + (proc-doc/names group:add-to-windows-menu (-> (-> (is-a?/c menu%) any) any) (proc) - @{Procedures passed to this function are called when the @onscreen{Windows} menu is - created. Use it to add additional menu items.}) - + @{Procedures passed to this function are called when the @onscreen{Windows} + menu is created. Use it to add additional menu items.}) + (proc-doc/names handler:handler? (any/c . -> . boolean?) (obj) @{This predicate determines if its input is a handler.}) - + (proc-doc/names handler:handler-name (handler:handler? . -> . string?) (handler) @{Extracts the name from a handler.}) - + (proc-doc/names handler:handler-extension (handler:handler? . -> . (or/c (path? . -> . boolean?) (listof string?))) (handler) @{Extracts the extension from a handler.}) - + (proc-doc/names handler:handler-handler (handler:handler? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (handler) - @{Extracs the handler's handling function.}) - + @{Extracts the handler's handling function.}) + (proc-doc/names handler:insert-format-handler (string? @@ -734,37 +729,37 @@ void?) (name pred handler) @{This function inserts a format handler. - - The string, @scheme[name] names the format handler for use with - @scheme[handler:find-named-format-handler]. If @scheme[pred] is a - string, it is matched with the extension of a filename by - @scheme[handler:find-format-handler]. If @scheme[pred] is a list of - strings, they are each matched with the extension of a filename by - @scheme[handler:find-format-handler]. If it is a function, the - filename is applied to the function and the functions result - determines if this is the handler to use. - - The most recently added format handler takes precedence over all - other format handlers.}) - + + The string, @scheme[name] names the format handler for use with + @scheme[handler:find-named-format-handler]. If @scheme[pred] is a string, + it is matched with the extension of a filename by + @scheme[handler:find-format-handler]. If @scheme[pred] is a list of + strings, they are each matched with the extension of a filename by + @scheme[handler:find-format-handler]. If it is a function, the filename is + applied to the function and the functions result determines if this is the + handler to use. + + The most recently added format handler takes precedence over all other + format handlers.}) + (proc-doc/names handler:find-named-format-handler (string? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (name) @{This function selects a format handler. See also - @scheme[handler:insert-format-handler]. - - It finds a handler based on @scheme[name].}) - + @scheme[handler:insert-format-handler]. + + It finds a handler based on @scheme[name].}) + (proc-doc/names handler:find-format-handler (path? . -> . (path? . -> . (is-a?/c frame:editor<%>))) (filename) @{This function selects a format handler. See also - @scheme[handler:insert-format-handler]. - - It finds a handler based on @scheme[filename].}) - + @scheme[handler:insert-format-handler]. + + It finds a handler based on @scheme[filename].}) + (proc-doc/names handler:edit-file (->* ((or/c path? false/c)) @@ -773,212 +768,206 @@ ((filename) ((make-default (λ () ((handler:current-create-new-window) filename))))) - @{This function creates a frame or re-uses an existing frame to edit a - file. - - If the preference @scheme['framework:open-here] is set to - @scheme[#t], and - @scheme[(send (group:get-the-frame-group) get-open-here-frame)] - returns a frame, the - @method[frame:open-here<%> open-here] method of that frame is used - to load the file in the existing frame. - - Otherwise, it invokes the appropriate format handler to open the - file (see @scheme[handler:insert-format-handler]). - - @itemize[ - @item{If @scheme[filename] is a string, this function checks the - result of @scheme[group:get-the-frame-group] to see if the - @scheme[filename] is already open by a frame in the group. - @itemize[ - @item{If so, it returns the frame.} - @item{If not, this function calls - @scheme[handler:find-format-handler] with - @scheme[filename]. - @itemize[ - @item{If a handler is found, it is applied to - @scheme[filename] and it's result is the - final result.} - @item{If not, @scheme[make-default] is used.}]}]} - @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] - is used.}]}) - + @{This function creates a frame or re-uses an existing frame to edit a file. + + If the preference @scheme['framework:open-here] is set to @scheme[#t], and + @scheme[(send (group:get-the-frame-group) get-open-here-frame)] returns a + frame, the @method[frame:open-here<%> open-here] method of that frame is + used to load the file in the existing frame. + + Otherwise, it invokes the appropriate format handler to open the file (see + @scheme[handler:insert-format-handler]). + + @itemize[ + @item{If @scheme[filename] is a string, this function checks the result + of @scheme[group:get-the-frame-group] to see if the + @scheme[filename] is already open by a frame in the group. + @itemize[ + @item{If so, it returns the frame.} + @item{If not, this function calls + @scheme[handler:find-format-handler] with + @scheme[filename]. + @itemize[ + @item{If a handler is found, it is applied to + @scheme[filename] and it's result is the final + result.} + @item{If not, @scheme[make-default] is used.}]}]} + @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] is + used.}]}) + (parameter-doc handler:current-create-new-window (parameter/c (-> (or/c false/c path?) (is-a?/c frame%))) proc - @{This is a parameter that controls how the framework creates new - application windows. - - The default setting is this: - @schemeblock[ - (λ (filename) - (let ([frame (make-object frame:text-info-file% filename)]) - (send frame show #t) - frame)) - ]}) - + @{This is a parameter that controls how the framework creates new application + windows. + + The default setting is this: + @schemeblock[(λ (filename) + (let ([frame (make-object frame:text-info-file% filename)]) + (send frame show #t) + frame))]}) + (proc-doc/names handler:open-file (->* () ((or/c false/c path? string?)) (or/c false/c (is-a?/c frame:basic<%>))) - (() + (() ((dir #f))) @{This function queries the user for a filename and opens the file for - editing. It uses @scheme[handler:edit-file] to open the file, once - the user has chosen it. - - Calls @scheme[finder:get-file] and @scheme[handler:edit-file], passing along @scheme[dir].}) - + editing. It uses @scheme[handler:edit-file] to open the file, once the + user has chosen it. + + Calls @scheme[finder:get-file] and @scheme[handler:edit-file], passing + along @scheme[dir].}) + (proc-doc/names handler:install-recent-items ((is-a?/c menu%) . -> . void?) (menu) - @{This function deletes all of the items in the given menu and adds - one menu item for each recently opened file. These menu items, when - selected, call @scheme[handler:edit-file] with the filename of the - recently opened file. - - The menu's size is limited to 10.}) - + @{This function deletes all of the items in the given menu and adds one menu + item for each recently opened file. These menu items, when selected, call + @scheme[handler:edit-file] with the filename of the recently opened file. + + The menu's size is limited to 10.}) + (proc-doc/names handler:set-recent-items-frame-superclass ((implementation?/c frame:standard-menus<%>) . -> . void?) (frame) @{Sets the superclass for the recently opened files frame. It must be - derived from @scheme[frame:standard-menus].}) - + derived from @scheme[frame:standard-menus].}) + (proc-doc/names handler:add-to-recent (path? . -> . void?) (filename) @{Adds a filename to the list of recently opened files.}) - + (proc-doc/names handler:set-recent-position (path? number? number? . -> . void?) (filename start end) @{Sets the selection of the recently opened file to @scheme[start] and - @scheme[end].}) - + @scheme[end].}) + (proc-doc/names handler:size-recently-opened-files (number? . -> . void?) (num) - @{Sizes the @scheme['framework:recently-opened-files/pos] preference - list length to @scheme[num].}) - + @{Sizes the @scheme['framework:recently-opened-files/pos] preference list + length to @scheme[num].}) + (proc-doc/names icon:get-paren-highlight-bitmap (-> (is-a?/c bitmap%)) () - @{This returns the parenthesis highlight @scheme[bitmap%]. It is only - used on black and white screens.}) - + @{This returns the parenthesis highlight @scheme[bitmap%]. It is only used + on black and white screens.}) + (proc-doc/names icon:get-eof-bitmap (-> (is-a?/c bitmap%)) () - @{This returns the @scheme[bitmap%] used for the clickable ``eof'' - icon from @scheme[text:ports].}) - + @{This returns the @scheme[bitmap%] used for the clickable ``eof'' icon from + @scheme[text:ports].}) + (proc-doc/names icon:get-autowrap-bitmap (-> (is-a?/c bitmap%)) () @{This returns the autowrap's @scheme[bitmap%]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-lock-bitmap (-> (is-a?/c bitmap%)) () @{This returns the lock's @scheme[bitmap]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-unlock-bitmap (-> (is-a?/c bitmap%)) () @{This returns the reset unlocked @scheme[bitmap]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-anchor-bitmap (-> (is-a?/c bitmap%)) () @{This returns the anchor's @scheme[bitmap]. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-left/right-cursor (-> (is-a?/c cursor%)) () - @{This function returns a @scheme[cursor%] object that indicates - left/right sizing is possible, for use with columns inside a window. - - The cursor may not respond @scheme[#t] to the @method[cursor% ok?] - method.}) - + @{This function returns a @scheme[cursor%] object that indicates left/right + sizing is possible, for use with columns inside a window. + + The cursor may not respond @scheme[#t] to the @method[cursor% ok?] + method.}) + (proc-doc/names icon:get-up/down-cursor (-> (is-a?/c cursor%)) () - @{This function returns a @scheme[cursor%] object that indicates - up/down sizing is possible, for use with columns inside a window. - - The cursor may not respond @scheme[#t] to the @method[cursor% ok?] - method.}) - + @{This function returns a @scheme[cursor%] object that indicates up/down + sizing is possible, for use with columns inside a window. + + The cursor may not respond @scheme[#t] to the @method[cursor% ok?] + method.}) + (proc-doc/names icon:get-gc-on-bitmap (-> (is-a?/c bitmap%)) () - @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] - frame when garbage collection is taking place. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] frame + when garbage collection is taking place. + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names icon:get-gc-off-bitmap (-> (is-a?/c bitmap%)) () - @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] - frame when garbage collection is not taking place. - - The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] - method.}) - + @{This returns a bitmap to be displayed in an @scheme[frame:info<%>] frame + when garbage collection is not taking place. + + The bitmap may not respond @scheme[#t] to the @method[bitmap% ok?] + method.}) + (proc-doc/names keymap:remove-user-keybindings-file (-> any/c any) (user-keybindings-path) @{Removes the keymap previously added by - @scheme[keymap:add-user-keybindings-file].}) - + @scheme[keymap:add-user-keybindings-file].}) + (proc-doc/names keymap:add-user-keybindings-file (-> any/c any) (user-keybindings-path-or-require-spec) - @{Chains the keymap defined by - @scheme[user-keybindings-path-or-require-spec] to the global keymap, - returned by @scheme[keymap:get-global]. - - If @scheme[user-keybindings-path-or-require-spec] is a path, the - module is loaded directly from that path. Otherwise, - @scheme[user-keybindings-path-or-require-spec] is treated like an - argument to @scheme[require].}) - + @{Chains the keymap defined by @scheme[user-keybindings-path-or-require-spec] + to the global keymap, returned by @scheme[keymap:get-global]. + + If @scheme[user-keybindings-path-or-require-spec] is a path, the module is + loaded directly from that path. Otherwise, + @scheme[user-keybindings-path-or-require-spec] is treated like an argument + to @scheme[require].}) + (parameter-doc keymap:add-to-right-button-menu (parameter/c @@ -987,64 +976,63 @@ (is-a?/c event%) void?)) proc - @{When the keymap that @scheme[keymap:get-global] returns is installed - into an editor, this parameter's value is used for right button - clicks. - - Before calling this procedure, the function - @scheme[append-editor-operation-menu-items] is called. - - See also @scheme[keymap:add-to-right-button-menu/before].}) - + @{When the keymap that @scheme[keymap:get-global] returns is installed into + an editor, this parameter's value is used for right button clicks. + + Before calling this procedure, the function + @scheme[append-editor-operation-menu-items] is called. + + See also @scheme[keymap:add-to-right-button-menu/before].}) + (parameter-doc keymap:add-to-right-button-menu/before (parameter/c (-> (is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) void?)) proc - @{When the keymap that @scheme[keymap:get-global] returns is installed - into an editor, this function is called for right button clicks. - - After calling this procedure, the function - @scheme[append-editor-operation-menu-items] is called. - - See also @scheme[keymap:add-to-right-button-menu].}) - + @{When the keymap that @scheme[keymap:get-global] returns is installed into + an editor, this function is called for right button clicks. + + After calling this procedure, the function + @scheme[append-editor-operation-menu-items] is called. + + See also @scheme[keymap:add-to-right-button-menu].}) + (proc-doc/names keymap:call/text-keymap-initializer ((-> any/c) . -> . any/c) (thunk-proc) - @{Thus function parameterizes the call to @scheme[thunk-proc] by - setting the keymap-initialization procedure (see - @scheme[current-text-keymap-initializer]) to install the framework's - standard text bindings.}) - + @{This function parameterizes the call to @scheme[thunk-proc] by setting the + keymap-initialization procedure (see + @scheme[current-text-keymap-initializer]) to install the framework's + standard text bindings.}) + (proc-doc/names keymap:canonicalize-keybinding-string (string? . -> . string?) (keybinding-string) - @{Returns a string that denotes the same keybindings as the input - string, except that it is in canonical form; two canonical - keybinding strings can be compared with @scheme[string=?].}) - + @{Returns a string that denotes the same keybindings as the input string, + except that it is in canonical form; two canonical keybinding strings can + be compared with @scheme[string=?].}) + (proc-doc/names keymap:get-editor (-> (is-a?/c keymap%)) () - @{This returns a keymap for handling standard editing operations. It - binds these keys: - - @itemize[ - @item{@scheme["z"]: undo} - @item{@scheme["y"]: redo} - @item{@scheme["x"]: cut} - @item{@scheme["c"]: copy} - @item{@scheme["v"]: paste} - @item{@scheme["a"]: select all}] - where each key is prefixed with the menu-shortcut key, based on the - platform. Under unix, the shortcut is @scheme["a:"]; under windows - the shortcut key is @scheme["c:"] and under MacOS, the shortcut key - is @scheme["d:"].}) - + @{This returns a keymap for handling standard editing operations. It binds + these keys: + + @itemize[ + @item{@scheme["z"]: undo} + @item{@scheme["y"]: redo} + @item{@scheme["x"]: cut} + @item{@scheme["c"]: copy} + @item{@scheme["v"]: paste} + @item{@scheme["a"]: select all}] + where each key is prefixed with the menu-shortcut key, based on the + platform. Under Unix, the shortcut is @scheme["a:"]; under windows the + shortcut key is @scheme["c:"] and under MacOS, the shortcut key is + @scheme["d:"].}) + (proc-doc/names keymap:get-file (-> (is-a?/c keymap%)) @@ -1055,239 +1043,227 @@ keymap:get-user (-> (is-a?/c keymap%)) () - @{This returns a keymap that contains all of the keybindings in the keymaps loaded via @scheme[keymap:add-user-keybindings-file]}) + @{This returns a keymap that contains all of the keybindings in the keymaps + loaded via @scheme[keymap:add-user-keybindings-file]}) - (proc-doc/names keymap:get-global (-> (is-a?/c keymap%)) () @{This returns a keymap for general operations. See - @scheme[keymap:setup-global] for a list of the bindings this keymap - contains.}) - + @scheme[keymap:setup-global] for a list of the bindings this keymap + contains.}) + (proc-doc/names keymap:get-search (-> (is-a?/c keymap%)) () @{This returns a keymap for searching operations.}) - + (proc-doc/names keymap:make-meta-prefix-list (string? . -> . (listof string?)) (key) - @{This prefixes a key with all of the different meta prefixes and - returns a list of the prefixed strings. - - takes a keymap, a base key specification, and a function name; it - prefixes the base key with all ``meta'' combination prefixes, and - installs the new combinations into the keymap. For example, - @scheme[(keymap:send-map-function-meta keymap "a" func)] maps - @scheme["m:a"] and @scheme["ESC;a"] to @scheme[func].}) - + @{This prefixes a key with all of the different meta prefixes and returns a + list of the prefixed strings. + + Takes a keymap, a base key specification, and a function name; it prefixes + the base key with all ``meta'' combination prefixes, and installs the new + combinations into the keymap. For example, + @scheme[(keymap:send-map-function-meta keymap "a" func)] maps + @scheme["m:a"] and @scheme["ESC;a"] to @scheme[func].}) + (proc-doc/names keymap:send-map-function-meta ((is-a?/c keymap%) string? string? . -> . void?) (keymap key func) - @{@index{Meta} Most keyboard and mouse mappings are inserted into a - keymap by calling the keymap's @method[keymap% map-function] method. - However, ``meta'' combinations require special attention. The - @scheme["m:"] prefix recognized by @method[keymap% map-function] - applies only to the Meta key that exists on some keyboards. By - convention, however, ``meta'' combinations can also be accessed by - using ``ESC'' as a prefix. - - This procedure binds all of the key-bindings obtained by prefixing - @scheme[key] with a meta-prefix to @scheme[func] in - @scheme[keymap].}) - + @{@index{Meta} Most keyboard and mouse mappings are inserted into a keymap by + calling the keymap's @method[keymap% map-function] method. However, + ``meta'' combinations require special attention. The @scheme["m:"] prefix + recognized by @method[keymap% map-function] applies only to the Meta key + that exists on some keyboards. By convention, however, ``meta'' + combinations can also be accessed by using ``ESC'' as a prefix. + + This procedure binds all of the key-bindings obtained by prefixing + @scheme[key] with a meta-prefix to @scheme[func] in @scheme[keymap].}) + (proc-doc/names keymap:setup-editor ((is-a?/c keymap%) . -> . void?) (keymap) @{This sets up the input keymap with the bindings described in - @scheme[keymap:get-editor].}) - + @scheme[keymap:get-editor].}) + (proc-doc/names keymap:setup-file ((is-a?/c keymap%) . -> . void?) (keymap) @{This extends a @scheme[keymap%] with the bindings for files.}) - + (proc-doc/names keymap:setup-global ((is-a?/c keymap%) . -> . void?) (keymap) - @{This extends a @scheme[keymap%] with the general bindings. - - This function extends a @scheme[keymap%] with the following - functions: - @itemize[ - @item{@mapdesc[ring-bell any] --- Rings the bell - (using @scheme[bell]) and removes the search panel from the frame, - if there.} - @item{@mapdesc[save-file key] --- Saves the buffer. If the buffer - has no name, then - @scheme[finder:put-file]@index["finder:put-file"] is - invoked.} - @item{@mapdesc[save-file-as key] --- Calls - @scheme[finder:put-file]@index["finder:put-file"] to save - the buffer.} - @item{@mapdesc[load-file key] --- Invokes - @scheme[finder:open-file]@index["finder:open-file"].} - @item{@mapdesc[find-string key] --- Opens the search buffer at the - bottom of the frame, unless it is already open, in which - case it searches for the text in the search buffer.} - @item{@mapdesc[find-string-reverse key] --- Same as - ``find-string'', but in the reverse direction.} - @item{@mapdesc[find-string-replace key] --- Opens a replace string - dialog box.} - @item{@mapdesc[toggle-anchor key] --- Turns selection-anchoring on - or off.} - @item{@mapdesc[center-view-on-line key] --- Centers the buffer in - its display using the currently selected line.} - @item{@mapdesc[collapse-space key] --- Collapses all non-return - whitespace around the caret into a single space.} - @item{@mapdesc[remove-space key] --- Removes all non-return - whitespace around the caret.} - @item{@mapdesc[collapse-newline key] --- Collapses all empty lines - around the caret into a single empty line. If there is only - one empty line, it is removed.} - @item{@mapdesc[open-line key] --- Inserts a new line.} - @item{@mapdesc[transpose-chars key] --- Transposes the characters - before and after the caret and moves forward one position.} - @item{@mapdesc[transpose-words key] --- Transposes words before - and after the caret and moves forward one word.} - @item{@mapdesc[capitalize-word key] --- Changes the first - character of the next word to a capital letter and moves to - the end of the word.} - @item{@mapdesc[upcase-word key] --- Changes all characters of the - next word to capital letters and moves to the end of the - word.} - @item{@mapdesc[downcase-word key] --- Changes all characters - of the next word to lowercase letters and moves to the end - of the word.} - @item{@mapdesc[kill-word key] --- Kills the next word.} - @item{@mapdesc[backward-kill-word key] --- Kills the previous - word.} - @item{@mapdesc[goto-line any] --- Queries the user for a line - number and moves the caret there.} - @item{@mapdesc[goto-position any] --- Queries the user for a - position number and moves the caret there.} - @item{@mapdesc[copy-clipboard mouse] --- Copies the current - selection to the clipboard.} - @item{@mapdesc[cut-clipboard mouse] --- Cuts the current selection - to the clipboard.} - @item{@mapdesc[paste-clipboard mouse] --- Patses the clipboard to - the current selection.} - @item{@mapdesc[copy-click-region mouse] --- Copies the region - between the caret and the input mouse event.} - @item{@mapdesc[cut-click-region mouse] --- Cuts the region - between the caret and the input mouse event.} - @item{@mapdesc[paste-click-region mouse] --- Pastes the clipboard - into the position of the input mouse event.} - @item{@mapdesc[select-click-word mouse] --- Selects the word under - the input mouse event.} - @item{@mapdesc[select-click-line mouse] --- Selects the line under - the input mouse event.} - @item{@mapdesc[start-macro key] -- Starts building a keyboard - macro} - @item{@mapdesc[end-macro key] --- Stops building a keyboard macro} - @item{@mapdesc[do-macro key] --- Executes the last keyboard macro} - @item{@mapdesc[toggle-overwrite key] --- Toggles overwriting - mode}] - - These functions are bound to the following keys - (C = control, S = shift, A = alt, M = ``meta'', D = command): - - @itemize[ - @item{C-g : ``ring-bell''} - @item{M-C-g : ``ring-bell''} - @item{C-c C-g : ``ring-bell''} - @item{C-x C-g : ``ring-bell''} - @item{C-p : ``previous-line''} - @item{S-C-p : ``select-previous-line''} - @item{C-n : ``next-line''} - @item{S-C-n : ``select-next-line''} - @item{C-e : ``end-of-line''} - @item{S-C-e : ``select-to-end-of-line''} - @item{D-RIGHT : ``end-of-line''} - @item{S-D-RIGHT : ``select-to-end-of-line''} - @item{M-RIGHT : ``end-of-line''} - @item{S-M-RIGHT : ``select-to-end-of-line''} - @item{C-a : ``beginning-of-line''} - @item{S-C-a : ``select-to-beginning-of-line''} - @item{D-LEFT : ``beginning-of-line''} - @item{D-S-LEFT : ``select-to-beginning-of-line''} - @item{M-LEFT : ``beginning-of-line''} - @item{M-S-LEFT : ``select-to-beginning-of-line''} - @item{C-h : ``delete-previous-character''} - @item{C-d : ``delete-next-character''} - @item{C-f : ``forward-character''} - @item{S-C-f : ``select-forward-character''} - @item{C-b : ``backward-character''} - @item{S-C-b : ``select-backward-character''} - @item{M-f : ``forward-word''} - @item{S-M-f : ``select-forward-word''} - @item{A-RIGHT : ``forward-word''} - @item{A-S-RIGHT : ``forward-select-word''} - @item{M-b : ``backward-word''} - @item{S-M-b : ``select-backward-word''} - @item{A-LEFT : ``backward-word''} - @item{A-S-LEFT : ``backward-select-word''} - @item{M-d : ``kill-word''} - @item{M-DELETE : ``backward-kill-word''} - @item{M-c : ``capitalize-word''} - @item{M-u : ``upcase-word''} - @item{M-l : ``downcase-word''} - @item{M-< : ``beginning-of-file''} - @item{S-M-< : ``select-to-beginning-of-file''} - @item{M-> : ``end-of-file''} - @item{S-M-> : ``select-to-end-of-file''} - @item{C-v : ``next-page''} - @item{S-C-v : ``select-next-page''} - @item{M-v : ``previous-page''} - @item{S-M-v : ``select-previous-page''} - @item{C-l : ``center-view-on-line''} - @item{C-k : ``delete-to-end-of-line''} - @item{C-y : ``paste-clipboard'' (Except Windows)} - @item{A-v : ``paste-clipboard''} - @item{D-v : ``paste-clipboard''} - @item{C-_ : ``undo''} - @item{C-x u : ``undo''} - @item{C-+ : ``redo''} - @item{C-w : ``cut-clipboard''} - @item{M-w : ``copy-clipboard''} - @item{C-x C-s : ``save-file''} - @item{C-x C-w : ``save-file-as''} - @item{C-x C-f : ``load-file''} - @item{C-s : ``find-string''} - @item{C-r : ``find-string-reverse''} - @item{M-% : ``find-string-replace''} - @item{SPACE : ``collapse-space''} - @item{M-Backslash : ``remove-space''} - @item{C-x C-o : ``collapse-newline''} - @item{C-o : ``open-line''} - @item{C-t : ``transpose-chars''} - @item{M-t : ``transpose-words''} - @item{C-SPACE : ``toggle-anchor''} - @item{M-g : ``goto-line''} - @item{M-p : ``goto-position''} - @item{LEFTBUTTONTRIPLE : ``select-click-line''} - @item{LEFTBUTTONDOUBLE : ``select-click-word''} - @item{RIGHTBUTTON : ``copy-click-region''} - @item{RIGHTBUTTONDOUBLE : ``cut-click-region''} - @item{MIDDLEBUTTON : ``paste-click-region''} - @item{C-RIGHTBUTTON : ``copy-clipboard''} - @item{INSERT : ``toggle-overwrite''} - @item{M-o : ``toggle-overwrite''}]}) - + @{This function extends a @scheme[keymap%] with the following functions: + @itemize[ + @item{@mapdesc[ring-bell any] --- Rings the bell (using @scheme[bell]) + and removes the search panel from the frame, if there.} + @item{@mapdesc[save-file key] --- Saves the buffer. If the buffer has no + name, then @scheme[finder:put-file]@index["finder:put-file"] is + invoked.} + @item{@mapdesc[save-file-as key] --- Calls + @scheme[finder:put-file]@index["finder:put-file"] to save the + buffer.} + @item{@mapdesc[load-file key] --- Invokes + @scheme[finder:open-file]@index["finder:open-file"].} + @item{@mapdesc[find-string key] --- Opens the search buffer at the bottom + of the frame, unless it is already open, in which case it searches + for the text in the search buffer.} + @item{@mapdesc[find-string-reverse key] --- Same as ``find-string'', but + in the reverse direction.} + @item{@mapdesc[find-string-replace key] --- Opens a replace string dialog + box.} + @item{@mapdesc[toggle-anchor key] --- Turns selection-anchoring on or + off.} + @item{@mapdesc[center-view-on-line key] --- Centers the buffer in its + display using the currently selected line.} + @item{@mapdesc[collapse-space key] --- Collapses all non-return + whitespace around the caret into a single space.} + @item{@mapdesc[remove-space key] --- Removes all non-return whitespace + around the caret.} + @item{@mapdesc[collapse-newline key] --- Collapses all empty lines around + the caret into a single empty line. If there is only one empty + line, it is removed.} + @item{@mapdesc[open-line key] --- Inserts a new line.} + @item{@mapdesc[transpose-chars key] --- Transposes the characters before + and after the caret and moves forward one position.} + @item{@mapdesc[transpose-words key] --- Transposes words before and after + the caret and moves forward one word.} + @item{@mapdesc[capitalize-word key] --- Changes the first character of + the next word to a capital letter and moves to the end of the + word.} + @item{@mapdesc[upcase-word key] --- Changes all characters of the next + word to capital letters and moves to the end of the word.} + @item{@mapdesc[downcase-word key] --- Changes all characters of the next + word to lowercase letters and moves to the end of the word.} + @item{@mapdesc[kill-word key] --- Kills the next word.} + @item{@mapdesc[backward-kill-word key] --- Kills the previous word.} + @item{@mapdesc[goto-line any] --- Queries the user for a line number and + moves the caret there.} + @item{@mapdesc[goto-position any] --- Queries the user for a position + number and moves the caret there.} + @item{@mapdesc[copy-clipboard mouse] --- Copies the current selection to + the clipboard.} + @item{@mapdesc[cut-clipboard mouse] --- Cuts the current selection to the + clipboard.} + @item{@mapdesc[paste-clipboard mouse] --- Pastes the clipboard to the + current selection.} + @item{@mapdesc[copy-click-region mouse] --- Copies the region between the + caret and the input mouse event.} + @item{@mapdesc[cut-click-region mouse] --- Cuts the region between the + caret and the input mouse event.} + @item{@mapdesc[paste-click-region mouse] --- Pastes the clipboard into + the position of the input mouse event.} + @item{@mapdesc[select-click-word mouse] --- Selects the word under the + input mouse event.} + @item{@mapdesc[select-click-line mouse] --- Selects the line under the + input mouse event.} + @item{@mapdesc[start-macro key] -- Starts recording a keyboard macro} + @item{@mapdesc[end-macro key] --- Stops recording a keyboard macro} + @item{@mapdesc[do-macro key] --- Executes the last keyboard macro} + @item{@mapdesc[toggle-overwrite key] --- Toggles overwriting mode}] + + These functions are bound to the following keys + (C = control, S = shift, A = alt, M = ``meta'', D = command): + + @itemize[ + @item{C-g : ``ring-bell''} + @item{M-C-g : ``ring-bell''} + @item{C-c C-g : ``ring-bell''} + @item{C-x C-g : ``ring-bell''} + @item{C-p : ``previous-line''} + @item{S-C-p : ``select-previous-line''} + @item{C-n : ``next-line''} + @item{S-C-n : ``select-next-line''} + @item{C-e : ``end-of-line''} + @item{S-C-e : ``select-to-end-of-line''} + @item{D-RIGHT : ``end-of-line''} + @item{S-D-RIGHT : ``select-to-end-of-line''} + @item{M-RIGHT : ``end-of-line''} + @item{S-M-RIGHT : ``select-to-end-of-line''} + @item{C-a : ``beginning-of-line''} + @item{S-C-a : ``select-to-beginning-of-line''} + @item{D-LEFT : ``beginning-of-line''} + @item{D-S-LEFT : ``select-to-beginning-of-line''} + @item{M-LEFT : ``beginning-of-line''} + @item{M-S-LEFT : ``select-to-beginning-of-line''} + @item{C-h : ``delete-previous-character''} + @item{C-d : ``delete-next-character''} + @item{C-f : ``forward-character''} + @item{S-C-f : ``select-forward-character''} + @item{C-b : ``backward-character''} + @item{S-C-b : ``select-backward-character''} + @item{M-f : ``forward-word''} + @item{S-M-f : ``select-forward-word''} + @item{A-RIGHT : ``forward-word''} + @item{A-S-RIGHT : ``forward-select-word''} + @item{M-b : ``backward-word''} + @item{S-M-b : ``select-backward-word''} + @item{A-LEFT : ``backward-word''} + @item{A-S-LEFT : ``backward-select-word''} + @item{M-d : ``kill-word''} + @item{M-DELETE : ``backward-kill-word''} + @item{M-c : ``capitalize-word''} + @item{M-u : ``upcase-word''} + @item{M-l : ``downcase-word''} + @item{M-< : ``beginning-of-file''} + @item{S-M-< : ``select-to-beginning-of-file''} + @item{M-> : ``end-of-file''} + @item{S-M-> : ``select-to-end-of-file''} + @item{C-v : ``next-page''} + @item{S-C-v : ``select-next-page''} + @item{M-v : ``previous-page''} + @item{S-M-v : ``select-previous-page''} + @item{C-l : ``center-view-on-line''} + @item{C-k : ``delete-to-end-of-line''} + @item{C-y : ``paste-clipboard'' (Except Windows)} + @item{A-v : ``paste-clipboard''} + @item{D-v : ``paste-clipboard''} + @item{C-_ : ``undo''} + @item{C-x u : ``undo''} + @item{C-+ : ``redo''} + @item{C-w : ``cut-clipboard''} + @item{M-w : ``copy-clipboard''} + @item{C-x C-s : ``save-file''} + @item{C-x C-w : ``save-file-as''} + @item{C-x C-f : ``load-file''} + @item{C-s : ``find-string''} + @item{C-r : ``find-string-reverse''} + @item{M-% : ``find-string-replace''} + @item{SPACE : ``collapse-space''} + @item{M-Backslash : ``remove-space''} + @item{C-x C-o : ``collapse-newline''} + @item{C-o : ``open-line''} + @item{C-t : ``transpose-chars''} + @item{M-t : ``transpose-words''} + @item{C-SPACE : ``toggle-anchor''} + @item{M-g : ``goto-line''} + @item{M-p : ``goto-position''} + @item{LEFTBUTTONTRIPLE : ``select-click-line''} + @item{LEFTBUTTONDOUBLE : ``select-click-word''} + @item{RIGHTBUTTON : ``copy-click-region''} + @item{RIGHTBUTTONDOUBLE : ``cut-click-region''} + @item{MIDDLEBUTTON : ``paste-click-region''} + @item{C-RIGHTBUTTON : ``copy-clipboard''} + @item{INSERT : ``toggle-overwrite''} + @item{M-o : ``toggle-overwrite''}]}) + (proc-doc/names keymap:setup-search ((is-a?/c keymap%) . -> . void?) (keymap) @{This extends a @scheme[keymap%] with the bindings for searching.}) - + (proc-doc/names keymap:set-chained-keymaps ((is-a?/c keymap:aug-keymap<%>) @@ -1296,9 +1272,8 @@ void?) (keymap children-keymaps) @{Sets @scheme[keymap]'s chained keymaps to @scheme[children-keymaps], - unchaining any keymaps that are currently chained to - @scheme[keymap].}) - + unchaining any keymaps that are currently chained to @scheme[keymap].}) + (proc-doc/names keymap:remove-chained-keymap ((is-a?/c editor<%>) @@ -1307,15 +1282,15 @@ void?) (editor keymap) @{Removes @scheme[keymap] from the keymaps chained to @scheme[editor]. - Also (indirectly) removes all keymaps chained to @scheme[keymap] - from @scheme[editor], since they are removed when unchaining - @scheme[keymap] itself. - - Each of the keymaps chained to @scheme[editor] must be an - @scheme[keymap:aug-keymap%] and @scheme[keymap] cannot be the result - of @scheme[(send editor get-keymap)] That is, @scheme[keymap] must - be chained to some keymap attached to the editor.}) - + Also (indirectly) removes all keymaps chained to @scheme[keymap] from + @scheme[editor], since they are removed when unchaining @scheme[keymap] + itself. + + Each of the keymaps chained to @scheme[editor] must be an + @scheme[keymap:aug-keymap%] and @scheme[keymap] cannot be the result of + @scheme[(send editor get-keymap)] That is, @scheme[keymap] must be chained + to some keymap attached to the editor.}) + (proc-doc/names scheme:text-balanced? (->* ((is-a?/c text%)) @@ -1323,137 +1298,135 @@ boolean?) ((text) ((start 0) (end #f))) - @{Determines if the range in the editor from @scheme[start] to - @scheme[end] in @scheme[text] has at least one complete s-expression and - there are no incomplete s-expressions. If - @scheme[end] is @scheme[#f], it defaults to the last position of the - @scheme[text]. - - The implementation of this function creates a port with - @scheme[open-input-text-editor] and then uses `read' to parse the - range of the buffer.}) - + @{Determines if the range in the editor from @scheme[start] to @scheme[end] + in @scheme[text] has at least one complete s-expression and there are no + incomplete s-expressions. If @scheme[end] is @scheme[#f], it defaults to + the last position of the @scheme[text]. The designation ``complete'' is + defined to be something that does not cause @racket[read] to raise a + @racket[exn:fail:read:eof?] exception, so there may be all kinds of strange + read-level (not to speak of parse level) errors in the expressions. + + The implementation of this function creates a port with + @scheme[open-input-text-editor] and then uses @racket[read] to parse the + range of the buffer.}) + (proc-doc/names scheme:add-preferences-panel (-> void?) () @{Adds a tabbing preferences panel to the preferences dialog.}) - + (proc-doc/names scheme:get-keymap (-> (is-a?/c keymap%)) () @{Returns a keymap with binding suitable for Racket.}) - + (proc-doc/names scheme:add-coloring-preferences-panel (-> any) () - @{ - Installs the ``Racket'' preferences panel in the ``Syntax Coloring'' - section.}) - + @{Installs the ``Racket'' preferences panel in the ``Syntax Coloring'' + section.}) + (proc-doc/names scheme:get-color-prefs-table (-> (listof (list/c symbol? (is-a?/c color%)))) () - @{Returns - a table mapping from symbols - (naming the categories that the online colorer uses for Racket mode coloring) to their colors. + @{Returns a table mapping from symbols (naming the categories that the online + colorer uses for Racket mode coloring) to their colors. These symbols are suitable for input to @scheme[scheme:short-sym->pref-name] and @scheme[scheme:short-sym->style-name]. See also @scheme[scheme:get-white-on-black-color-prefs-table].}) - + (proc-doc/names scheme:get-white-on-black-color-prefs-table (-> (listof (list/c symbol? (is-a?/c color%)))) () - @{Returns - a table mapping from symbols - (naming the categories that the online colorer uses for Racket mode coloring) to their colors when - the user chooses the white-on-black mode in the preferences dialog. + @{Returns a table mapping from symbols (naming the categories that the online + colorer uses for Racket mode coloring) to their colors when the user + chooses the white-on-black mode in the preferences dialog. See also @scheme[scheme:get-color-prefs-table].}) - + (proc-doc/names scheme:short-sym->pref-name (symbol? . -> . symbol?) (short-sym) - @{Builds the symbol naming the preference from one of the symbols in - the table returned by @scheme[scheme:get-color-prefs-table].}) - + @{Builds the symbol naming the preference from one of the symbols in the + table returned by @scheme[scheme:get-color-prefs-table].}) + (proc-doc/names scheme:short-sym->style-name (symbol? . -> . string?) (short-sym) - @{Builds the symbol naming the editor style from one of the symbols in - the table returned by @scheme[scheme:get-color-prefs-table]. This - style is a named style in the style list returned by - @scheme[editor:get-standard-style-list].}) - + @{Builds the symbol naming the editor style from one of the symbols in the + table returned by @scheme[scheme:get-color-prefs-table]. This style is a + named style in the style list returned by + @scheme[editor:get-standard-style-list].}) + (proc-doc/names scheme:get-wordbreak-map (-> (is-a?/c editor-wordbreak-map%)) () - @{This method returns a @scheme[editor-wordbreak-map%] that is suitable - for Racket.}) - + @{This method returns a @scheme[editor-wordbreak-map%] that is suitable for + Racket.}) + (proc-doc/names scheme:init-wordbreak-map ((is-a?/c keymap%) . -> . void?) (key) @{Initializes the workdbreak map for @scheme[keymap].}) - + (proc-doc/names scheme:setup-keymap ((is-a?/c keymap%) . -> . void?) (keymap) @{Initializes @scheme[keymap] with Racket-mode keybindings.}) - + (proc-doc/names editor:set-default-font-color (-> (is-a?/c color%) void?) (color) @{Sets the color of the style named - @scheme[editor:get-default-color-style-name].}) - + @scheme[editor:get-default-color-style-name].}) + (proc-doc/names editor:get-default-color-style-name (-> string?) () @{The name of the style (in the list returned by - @scheme[editor:get-standard-style-list]) that holds the default - color.}) - + @scheme[editor:get-standard-style-list]) that holds the default color.}) + (proc-doc/names editor:set-standard-style-list-delta (string? (is-a?/c style-delta%) . -> . void?) (name delta) @{Finds (or creates) the style named by @scheme[name] in the result of - @scheme[editor:get-standard-style-list] and sets its delta to - @scheme[delta]. - - If the style named by @scheme[name] is already in the style list, it - must be a delta style.}) - + @scheme[editor:get-standard-style-list] and sets its delta to + @scheme[delta]. + + If the style named by @scheme[name] is already in the style list, it must + be a delta style.}) + (proc-doc/names editor:set-standard-style-list-pref-callbacks (-> any) () - @{Installs the font preference callbacks that update the style list - returned by @scheme[editor:get-standard-style-list] based on the - font preference symbols.}) - + @{Installs the font preference callbacks that update the style list returned + by @scheme[editor:get-standard-style-list] based on the font preference + symbols.}) + (proc-doc/names editor:get-standard-style-list (-> (is-a?/c style-list%)) () @{Returns a style list that is used for all instances of - @scheme[editor:standard-style-list%].}) - + @scheme[editor:standard-style-list%].}) + (proc-doc/names editor:add-after-user-keymap (-> (is-a?/c keymap%) (listof (is-a?/c keymap%)) (listof (is-a?/c keymap%))) @@ -1462,62 +1435,60 @@ same relative order, but also with @scheme[keymap], where @scheme[keymap] is now the first keymap after @scheme[keymap:get-user] (if that keymap is in the list.)}) - + (proc-doc/names color-model:rgb->xyz (number? number? number? . -> . color-model:xyz?) (r g b) - @{Converts a color represented as a red-green-blue tuple (each value - from 0 to 255) into an XYZ tuple. This describes a point in the CIE - XYZ color space.}) - + @{Converts a color represented as a red-green-blue tuple (each value from 0 + to 255) into an XYZ tuple. This describes a point in the CIE + XYZ color space.}) + (proc-doc/names color-model:rgb-color-distance (number? number? number? number? number? number? . -> . number?) (red-a green-a blue-a red-b green-b blue-b) - @{This calculates a distance between two colors. The smaller the - distance, the closer the colors should appear to the human eye. A - distance of 10 is reasonably close that it could be called the same - color. - - This function is not symmetric in red, green, and blue, so it is - important to pass red, green, and blue components of the colors in - the proper order. The first three arguments are red, green and - blue for the first color, respectively, and the second three - arguments are red green and blue for the second color, - respectively.}) - + @{This calculates a distance between two colors. The smaller the distance, + the closer the colors should appear to the human eye. A distance of 10 is + reasonably close that it could be called the same color. + + This function is not symmetric in red, green, and blue, so it is important + to pass red, green, and blue components of the colors in the proper order. + The first three arguments are red, green and blue for the first color, + respectively, and the second three arguments are red green and blue for the + second color, respectively.}) + (proc-doc/names color-model:xyz->rgb (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.}) - + @{Converts an XYZ-tuple (in the CIE XYZ colorspace) into a list of values + representing an RGB-tuple.}) + (proc-doc/names color-model:xyz? (any/c . -> . boolean?) (val) @{Determines if @scheme[val] an xyz color record.}) - + (proc-doc/names color-model:xyz-x (color-model:xyz? . -> . number?) (xyz) @{Extracts the x component of @scheme[xyz].}) - + (proc-doc/names color-model:xyz-y (color-model:xyz? . -> . number?) (xyz) @{Extracts the y component of @scheme[xyz].}) - + (proc-doc/names color-model:xyz-z (color-model:xyz? . -> . number?) (xyz) @{Extracts the z component of @scheme[xyz].}) - + (proc-doc/names color-prefs:set-default/color-scheme (-> symbol? @@ -1525,14 +1496,13 @@ (or/c (is-a?/c color%) string?) void?) (pref-sym black-on-white-color white-on-black-color) - @{Registers a preference whose value will be updated when the user - clicks on one of the color scheme default settings in the - preferences dialog. - - Also calls @scheme[preferences:set-default] and - @scheme[preferences:set-un/marshall] with appropriate arguments to - register the preference.}) - + @{Registers a preference whose value will be updated when the user clicks on + one of the color scheme default settings in the preferences dialog. + + Also calls @scheme[preferences:set-default] and + @scheme[preferences:set-un/marshall] with appropriate arguments to register + the preference.}) + (proc-doc/names color-prefs:register-color-preference (->* (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%))) @@ -1540,78 +1510,78 @@ void?) ((pref-name style-name color/sd) ((white-on-black-color #f))) - @{This function registers a color preference and initializes the style - list returned from @scheme[editor:get-standard-style-list]. In - particular, it calls @scheme[preferences:set-default] and - @scheme[preferences:set-un/marshall] to install the pref for - @scheme[pref-name], using @scheme[color/sd] as the default - color. The preference is bound to a @scheme[style-delta%], and - initially the @scheme[style-delta%] changes the foreground color to - @scheme[color/sd], unless @scheme[color/sd] is a style delta - already, in which case it is just used directly. Then, it calls - @scheme[editor:set-standard-style-list-delta] passing the - @scheme[style-name] and the current value of the preference - @scheme[pref-name]. - - Finally, it adds calls @scheme[preferences:add-callback] to set a - callback for @scheme[pref-name] that updates the style list when the - preference changes. - - If @scheme[white-on-black-color] is not @scheme[#f], then the color - of the @scheme[color/sd] argument is used in combination with - @scheme[white-on-black-color] to register this preference with - @scheme[color-prefs:set-default/color-scheme].}) - + @{This function registers a color preference and initializes the style list + returned from @scheme[editor:get-standard-style-list]. In particular, it + calls @scheme[preferences:set-default] and + @scheme[preferences:set-un/marshall] to install the pref for + @scheme[pref-name], using @scheme[color/sd] as the default color. The + preference is bound to a @scheme[style-delta%], and initially the + @scheme[style-delta%] changes the foreground color to @scheme[color/sd], + unless @scheme[color/sd] is a style delta already, in which case it is just + used directly. Then, it calls + @scheme[editor:set-standard-style-list-delta] passing the + @scheme[style-name] and the current value of the preference + @scheme[pref-name]. + + Finally, it adds calls @scheme[preferences:add-callback] to set a callback + for @scheme[pref-name] that updates the style list when the preference + changes. + + If @scheme[white-on-black-color] is not @scheme[#f], then the color of the + @scheme[color/sd] argument is used in combination with + @scheme[white-on-black-color] to register this preference with + @scheme[color-prefs:set-default/color-scheme].}) + (proc-doc/names color-prefs:add-background-preferences-panel (-> void?) () @{Adds a preferences panel that configures the background color for - @scheme[editor:basic-mixin].}) - + @scheme[editor:basic-mixin].}) + (proc-doc/names color-prefs:add-to-preferences-panel (string? ((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (name func) - @{Calls @scheme[func] with the subpanel of the preferences coloring - panel that corresponds to @scheme[name].}) - + @{Calls @scheme[func] with the subpanel of the preferences coloring panel + that corresponds to @scheme[name].}) + (proc-doc/names color-prefs:build-color-selection-panel ((is-a?/c area-container<%>) symbol? string? string? . -> . void?) (parent pref-sym style-name example-text) - @{Builds a panel with a number of controls for configuring a font: the - color and check boxes for bold, italic, and underline. The - @scheme[parent] argument specifies where the panel will be placed. - The @scheme[pref-sym] should be a preference - (suitable for use with @scheme[preferences:get] and @scheme[preferences:set]). - The - @scheme[style-name] specifies the name of a style in the style list - returned from @scheme[editor:get-standard-style-list] and - @scheme[example-text] is shown in the panel so users can see the - results of their configuration.}) - + @{Builds a panel with a number of controls for configuring a font: the color + and check boxes for bold, italic, and underline. The @scheme[parent] + argument specifies where the panel will be placed. The @scheme[pref-sym] + should be a preference (suitable for use with @scheme[preferences:get] and + @scheme[preferences:set]). The @scheme[style-name] specifies the name of a + style in the style list returned from + @scheme[editor:get-standard-style-list] and @scheme[example-text] is shown + in the panel so users can see the results of their configuration.}) + (proc-doc/names color-prefs:marshall-style-delta (-> (is-a?/c style-delta%) printable/c) (style-delta) @{Builds a printed representation for a style-delta.}) - + (proc-doc/names color-prefs:unmarshall-style-delta (-> printable/c (or/c false/c (is-a?/c style-delta%))) (marshalled-style-delta) - @{Builds a style delta from its printed representation. Returns - @scheme[#f] if the printed form cannot be parsed.}) - + @{Builds a style delta from its printed representation. Returns @scheme[#f] + if the printed form cannot be parsed.}) + (proc-doc/names color-prefs:white-on-black (-> any) () - @{Sets the colors registered by @scheme[color-prefs:register-color-preference] to their white-on-black variety. }) - + @{Sets the colors registered by @scheme[color-prefs:register-color-preference] + to their white-on-black variety.}) + (proc-doc/names color-prefs:black-on-white (-> any) () - @{Sets the colors registered by @scheme[color-prefs:register-color-preference] to their black-on-white variety. })) + @{Sets the colors registered by @scheme[color-prefs:register-color-preference] + to their black-on-white variety.})) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index dbec9584..ce875d51 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -29,7 +29,7 @@ the state transitions / contracts are: (require scribble/srcdoc scheme/class scheme/gui/base scheme/contract scheme/file) -(require/doc scheme/base scribble/manual) +(require/doc scheme/base scribble/manual (for-label racket/serialize)) (provide exn:struct:unknown-preference) @@ -132,31 +132,58 @@ the state transitions / contracts are: ;; set : symbol any -> void ;; updates the preference ;; exported - (define (multi-set ps values) - (for-each - (λ (p value) - (cond - [(pref-default-set? p) - (let ([default (hash-ref defaults p)]) - (unless ((default-checker default) value) - (error 'preferences:set - "tried to set preference ~e to ~e but it does not meet test from preferences:set-default" - p value)) - (check-callbacks p value) - (hash-set! preferences p value))] - [(not (pref-default-set? p)) - (raise-unknown-preference-error - 'preferences:set "tried to set the preference ~e to ~e, but no default is set" - p - value)])) - ps values) - ((preferences:low-level-put-preferences) - (map add-pref-prefix ps) - (map (λ (p value) (marshall-pref p value)) - ps - values)) - (void)) + (dynamic-wind + (λ () + (call-pref-save-callbacks #t)) + (λ () + (for-each + (λ (p value) + (cond + [(pref-default-set? p) + (let ([default (hash-ref defaults p)]) + (unless ((default-checker default) value) + (error 'preferences:set + "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" + p value)) + (check-callbacks p value) + (hash-set! preferences p value))] + [(not (pref-default-set? p)) + (raise-unknown-preference-error + 'preferences:set "tried to set the preference ~e to ~e, but no default is set" + p + value)])) + ps values) + ((preferences:low-level-put-preferences) + (map add-pref-prefix ps) + (map (λ (p value) (marshall-pref p value)) + ps + values)) + (void)) + (λ () + (call-pref-save-callbacks #f)))) + +(define pref-save-callbacks '()) + +(define (preferences:register-save-callback f) + (define key (gensym)) + (set! pref-save-callbacks (cons (list key f) pref-save-callbacks)) + key) + +(define (preferences:unregister-save-callback k) + (set! pref-save-callbacks + (let loop ([callbacks pref-save-callbacks]) + (cond + [(null? callbacks) '()] + [else + (let ([cb (car callbacks)]) + (if (eq? (list-ref cb 0) k) + (cdr callbacks) + (cons cb (loop (cdr callbacks)))))])))) + +(define (call-pref-save-callbacks b) + (for ([cb (in-list pref-save-callbacks)]) + ((list-ref cb 1) b))) (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference @@ -244,7 +271,7 @@ the state transitions / contracts are: (pref-can-init? p)) (let ([default-okay? (checker default-value)]) (unless default-okay? - (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" + (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t\n" p checker default-okay? default-value))) (unless (= (length aliases) (length rewrite-aliases)) @@ -378,7 +405,7 @@ the state transitions / contracts are: #:rewrite-aliases (listof (-> any/c any))) void?) ((symbol value test) - ((aliases '()) (rewrite-aliases (map (lambda (x) (values)) aliases)))) + ((aliases '()) (rewrite-aliases (map (lambda (x) values) aliases)))) @{This function must be called every time your application starts up, before any call to @scheme[preferences:get] or @scheme[preferences:set] (for any given preference). @@ -407,13 +434,13 @@ the state transitions / contracts are: preferences:set-un/marshall (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?) (symbol marshall unmarshall) - @{@scheme[preference:set-un/marshall] is used to specify marshalling and + @{@scheme[preferences:set-un/marshall] is used to specify marshalling and unmarshalling functions for the preference @scheme[symbol]. @scheme[marshall] will be called when the users saves their preferences to turn the preference value for @scheme[symbol] into a printable value. @scheme[unmarshall] will be called when the user's preferences are read from the file to transform the printable value - into its internal representation. If @scheme[preference:set-un/marshall] + into its internal representation. If @scheme[preferences:set-un/marshall] is never called for a particular preference, the values of that preference are assumed to be printable. @@ -427,8 +454,11 @@ the state transitions / contracts are: happen when the preferences file becomes corrupted, or is edited by hand. - @scheme[preference:set-un/marshall] must be called before calling - @scheme[preferences:get],@scheme[preferences:set].}) + @scheme[preferences:set-un/marshall] must be called before calling + @scheme[preferences:get],@scheme[preferences:set]. + + See also @racket[serialize] and @racket[deserialize]. + }) (proc-doc/names preferences:restore-defaults @@ -437,6 +467,24 @@ the state transitions / contracts are: @{@scheme[(preferences:restore-defaults)] restores the users' configuration to the default preferences.}) + (proc-doc/names + preferences:register-save-callback + (-> (-> boolean? any) symbol?) + (callback) + @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once + before the preferences file is written, with @racket[#t], and once after it is written, with + @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback]. + Caveats: + @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].} + @item{Pre- and post-write notifications are not necessarily paired; unregistration + may cancel the post-write notification before it occurs.}}}) + + (proc-doc/names + preferences:unregister-save-callback + (-> symbol? void?) + (key) + @{Unregisters the save callback associated with @racket[key].}) + (proc-doc/names exn:make-unknown-preference (string? continuation-mark-set? . -> . exn:unknown-preference?) diff --git a/collects/framework/private/bday.rkt b/collects/framework/private/bday.rkt index 42dabb81..7f6e6890 100644 --- a/collects/framework/private/bday.rkt +++ b/collects/framework/private/bday.rkt @@ -1,32 +1,34 @@ #lang s-exp framework/private/decode - XY9BD - sIgEEWv - 8pfMgqRV - E3Whn - qXtT - GOjg - AE08 - fYWp - 62Nu - 897D - PMxjx - heAwtc - 7G3Lzfs - CN4 d0m - 4K0G giGp - R+8w JgC4 - MA0w rvkk - XCTR 5GkC - 56T Peux - e8Yo PtsJ - E5X7 jWeY - E74T 1gWf - ryiR 4OjH - y/tK Waem - 1XMZ aIU9 - ttXK LuXV - 1hU2 x7WO - f75G vdLLj - 9Xuc CD6A - \\\\ A== + TY+9Ds + IwDIT3P + MWN9hCJA + hIwAA + +CGN + rGFR + UkRW + lA4u + 1JaF + K6ne + /zz1n + R0w/v + 3gis73R + j6s8Zto + jxn oU0 + k2Cl yEjX + OwFR cmBh + mBVA Dwmg + i6lD RKO0 + gzOj Pk1l + +/Je XNDZ + Zr6m iThT + OwM6 glKb + toML NyTJ + sPz3 05XJ + jZd4 kaCE + iot+ UbDD + ZhUb Cp/f + yLxa YX1Y + 8vnh zCug + WvD5 +7J/C + +wj/ \wI=;; diff --git a/collects/framework/private/color-model.rkt b/collects/framework/private/color-model.rkt index 9a45c779..a18e0152 100644 --- a/collects/framework/private/color-model.rkt +++ b/collects/framework/private/color-model.rkt @@ -192,7 +192,7 @@ (,(xyz-z xyz-white))))]) (apply values (car (transpose sigmas))))) - ;; (printf "should be equal to xyz-white: ~n~a~n" + ;; (printf "should be equal to xyz-white: \n~a\n" ;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b)))) (define rgb->xyz-matrix @@ -203,13 +203,13 @@ (define xyz->rgb-matrix (matrix-invert rgb->xyz-matrix)) - ;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) + ;;(printf "should be identity: \n~a\n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) (define (rgb->xyz r g b) (apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b)))))))) ;;(print-struct #t) - ;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255)) + ;; (printf "should be xyz-white: \n~a\n" (rgb->xyz 255 255 255)) (define (xyz->rgb x y z) (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z))))))) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index f6a5dd6d..25ee0731 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -286,7 +286,7 @@ added get-regions (enable-suspend #t)))]) (unless (eq? 'eof type) (enable-suspend #f) - #; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) + #; (printf "~a at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) (+ in-start-pos (sub1 new-token-end))) (let ((len (- new-token-end new-token-start))) (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) @@ -418,11 +418,11 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) - #;(printf "revision ~a~n" (get-revision-number)) + #;(printf "revision ~a\n" (get-revision-number)) (unless (and tok-cor (= rev (get-revision-number))) (when tok-cor (coroutine-kill tok-cor)) - #;(printf "new coroutine~n") + #;(printf "new coroutine\n") (set! tok-cor (coroutine (λ (enable-suspend) @@ -450,19 +450,19 @@ added get-regions (format "exception in colorer thread: ~s" exn) exn)) (set! tok-cor #f)))) - #;(printf "begin lexing~n") + #;(printf "begin lexing\n") (when (coroutine-run 10 tok-cor) (for-each (lambda (ls) (set-lexer-state-up-to-date?! ls #t)) lexer-states))) - #;(printf "end lexing~n") - #;(printf "begin coloring~n") + #;(printf "end lexing\n") + #;(printf "begin coloring\n") ;; This edit sequence needs to happen even when colors is null ;; for the paren highlighter. (begin-edit-sequence #f #f) (color) (end-edit-sequence) - #;(printf "end coloring~n"))) + #;(printf "end coloring\n"))) (define/private (colorer-callback) (cond @@ -643,7 +643,7 @@ added get-regions ;; possible. (define/private match-parens (lambda ([just-clear? #f]) - ;;(printf "(match-parens ~a)~n" just-clear?) + ;;(printf "(match-parens ~a)\n" just-clear?) (when (and (not in-match-parens?) ;; Trying to match open parens while the ;; background thread is going slows it down. @@ -918,21 +918,21 @@ added get-regions (let* ((x null) (f (λ (a b c) (set! x (cons (list a b c) x))))) (send (lexer-state-tokens ls) for-each f) - (printf "tokens: ~e~n" (reverse x)) + (printf "tokens: ~.s\n" (reverse x)) (set! x null) (send (lexer-state-invalid-tokens ls) for-each f) - (printf "invalid-tokens: ~e~n" (reverse x)) - (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n" + (printf "invalid-tokens: ~.s\n" (reverse x)) + (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a\n" (lexer-state-start-pos ls) (lexer-state-current-pos ls) (lexer-state-invalid-tokens-start ls)) - (printf "parens: ~e~n" (car (send (lexer-state-parens ls) test))))) + (printf "parens: ~.s\n" (car (send (lexer-state-parens ls) test))))) lexer-states)) ;; ------------------------- Callbacks to Override ---------------------- (define/override (lock x) - ;;(printf "(lock ~a)~n" x) + ;;(printf "(lock ~a)\n" x) (super lock x) (when (and restart-callback (not x)) (set! restart-callback #f) @@ -940,25 +940,25 @@ added get-regions (define/override (on-focus on?) - ;;(printf "(on-focus ~a)~n" on?) + ;;(printf "(on-focus ~a)\n" on?) (super on-focus on?) (match-parens (not on?))) (define/augment (after-edit-sequence) - ;;(printf "(after-edit-sequence)~n") + ;;(printf "(after-edit-sequence)\n") (when (has-focus?) (match-parens)) (inner (void) after-edit-sequence)) (define/augment (after-set-position) - ;;(printf "(after-set-position)~n") + ;;(printf "(after-set-position)\n") (unless (local-edit-sequence?) (when (has-focus?) (match-parens))) (inner (void) after-set-position)) (define/augment (after-change-style a b) - ;;(printf "(after-change-style)~n") + ;;(printf "(after-change-style)\n") (unless (get-styles-fixed) (unless (local-edit-sequence?) (when (has-focus?) @@ -966,19 +966,19 @@ added get-regions (inner (void) after-change-style a b)) (define/augment (on-set-size-constraint) - ;;(printf "(on-set-size-constraint)~n") + ;;(printf "(on-set-size-constraint)\n") (unless (local-edit-sequence?) (when (has-focus?) (match-parens))) (inner (void) on-set-size-constraint)) (define/augment (after-insert edit-start-pos change-length) - ;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length) + ;;(printf "(after-insert ~a ~a)\n" edit-start-pos change-length) (do-insert/delete edit-start-pos change-length) (inner (void) after-insert edit-start-pos change-length)) (define/augment (after-delete edit-start-pos change-length) - ;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length) + ;;(printf "(after-delete ~a ~a)\n" edit-start-pos change-length) (do-insert/delete edit-start-pos (- change-length)) (inner (void) after-delete edit-start-pos change-length)) diff --git a/collects/framework/private/decode.rkt b/collects/framework/private/decode.rkt index 0944528e..6f21e079 100644 --- a/collects/framework/private/decode.rkt +++ b/collects/framework/private/decode.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require (for-syntax scheme/base file/gunzip net/base64)) -(provide (except-out (all-from-out scheme/base) #%module-begin) +#lang racket/base +(require (for-syntax racket/base file/gunzip net/base64)) +(provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [module-begin #%module-begin])) (define-syntax (module-begin stx) diff --git a/collects/framework/private/editor.rkt b/collects/framework/private/editor.rkt index 3c0b3537..0c8981b6 100644 --- a/collects/framework/private/editor.rkt +++ b/collects/framework/private/editor.rkt @@ -242,10 +242,10 @@ (unless (and (procedure? t) (= 0 (procedure-arity t))) (error 'editor:basic::run-after-edit-sequence - "expected procedure of arity zero, got: ~s~n" t)) + "expected procedure of arity zero, got: ~s\n" t)) (unless (or (symbol? sym) (not sym)) (error 'editor:basic::run-after-edit-sequence - "expected second argument to be a symbol or #f, got: ~s~n" + "expected second argument to be a symbol or #f, got: ~s\n" sym)) (if (refresh-delayed?) (if in-local-edit-sequence? diff --git a/collects/framework/private/encode.rkt b/collects/framework/private/encode.rkt index 4e3c455c..31b876d4 100644 --- a/collects/framework/private/encode.rkt +++ b/collects/framework/private/encode.rkt @@ -1,43 +1,34 @@ -#lang scheme/base -(require scheme/cmdline scheme/string scheme/match scheme/pretty - file/gzip file/gunzip net/base64) +#lang racket/base +(require racket/cmdline racket/string file/gzip file/gunzip net/base64) -(define (encode-exprs exprs) - (define in - (open-input-string - (string-join (map (lambda (x) (format "~s" x)) exprs) " "))) - (define out (open-output-bytes)) - (deflate in out) - (base64-encode (get-output-bytes out))) +(define do-lang? #f) -(define (encode-module) - (define mod (parameterize ([read-accept-reader #t]) (read))) - (when (eof-object? mod) (error 'encode-module "missing module")) - (match mod - [(list 'module m 'scheme/base (list '#%module-begin exprs ...)) - (write-bytes #"#lang s-exp framework/private/decode\n") - (write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))] - [else (error 'encode-module "cannot parse module, must use scheme/base")])) +(define (encode/decode-text who lang-from lang-to convert1 convert2) + (when do-lang? + (let ([l (cadr (or (regexp-match #rx"^ *#lang +(.*[^ ]) *$" (read-line)) + (error who "missing #lang line")))]) + (if (equal? l lang-from) + (printf "#lang ~a\n" lang-to) + (error who "bad #lang: expected ~s, got ~s" lang-from l)))) + (define O (open-output-bytes)) + (convert1 (current-input-port) O) + (convert2 (open-input-bytes (get-output-bytes O)) (current-output-port)) + (flush-output)) -(define (decode-module) - (define mod (parameterize ([read-accept-reader #t]) (read))) - (when (eof-object? mod) (error 'encode-module "missing module")) - (match mod - [(list 'module m 'framework/private/decode - (list '#%module-begin exprs ...)) - (write-bytes #"#lang scheme/base\n") - (let* ([data (format "~a" exprs)] - [data (substring data 1 (sub1 (string-length data)))] - [data (string->bytes/utf-8 data)] - [in (open-input-bytes (base64-decode data))] - [out (open-output-string)] - [out (begin (inflate in out) (get-output-string out))] - [exprs (read (open-input-string (string-append "(" out ")")))]) - (for ([expr (in-list exprs)]) - (pretty-print expr)))] - [else (error 'decode-module "cannot parse module, must use scheme/base")])) +(define (encode-text) + (encode/decode-text + 'encode-text "racket/base" "s-exp framework/private/decode" + deflate base64-encode-stream)) -(command-line #:once-any - ["-e" "encode" (encode-module) (exit)] - ["-d" "decode" (decode-module) (exit)]) +(define (decode-text) + (encode/decode-text + 'decode-text "s-exp framework/private/decode" "racket/base" + base64-decode-stream inflate)) + +(command-line + #:once-each + ["-l" "translate lang line" (set! do-lang? #t)] + #:once-any + ["-e" "encode" (encode-text) (exit)] + ["-d" "decode" (decode-text) (exit)]) (printf "Use `-h' for help\n") diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 46c89c73..21b1e5ce 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -44,7 +44,8 @@ items)) (let* ([file-menu (find-menu (string-constant file-menu))] [edit-menu (find-menu (string-constant edit-menu))] - [windows-menu (find-menu (string-constant windows-menu))] + [windows-menu (or (find-menu (string-constant windows-menu)) + (find-menu (string-constant tabs-menu)))] [help-menu (find-menu (string-constant help-menu))] [other-items (remq* (list file-menu edit-menu windows-menu help-menu) items)] @@ -212,10 +213,11 @@ (set-icon icon (send icon get-loaded-mask) 'both)))) (let ([mb (make-object (get-menu-bar%) this)]) - (when (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) - mb))) + (make-object menu:can-restore-underscore-menu% + (case (system-type) + [(macosx) (string-constant windows-menu-label)] + [else (string-constant tabs-menu-label)]) + mb)) (reorder-menus this) @@ -560,6 +562,7 @@ (λ (l) (if (memq outer-info-panel l) (begin (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (list rest-panel)) l)))] [else @@ -569,6 +572,7 @@ l (begin (register-gc-blit) + (register-pref-save-callback) (list rest-panel outer-info-panel)))))])) [define close-panel-callback @@ -580,6 +584,7 @@ (define/augment (on-close) (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (close-panel-callback) (memory-cleanup) (inner (void) on-close)) @@ -637,6 +642,12 @@ [(<= n 99) (format "0~a" n)] [else (number->string n)])) + (define pref-save-canvas #f) + (when checkout-or-nightly? + (set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)]))) + + [define lock-canvas (make-object lock-canvas% (get-info-panel))] + ; only for checkouts and nightly build users (when show-memory-text? (let* ([panel (new horizontal-panel% @@ -657,7 +668,6 @@ (set! memory-canvases (remq ec memory-canvases)))) (send panel stretchable-width #f))) - [define lock-canvas (make-object lock-canvas% (get-info-panel))] [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] (define/private (register-gc-blit) (let ([onb (icon:get-gc-on-bitmap)] @@ -670,6 +680,25 @@ (send onb get-height) onb offb)))) + (define pref-save-callback-registration #f) + (inherit get-eventspace) + (define/private (register-pref-save-callback) + (when pref-save-canvas + (set! pref-save-callback-registration + (preferences:register-save-callback + (λ (start?) + (cond + [(eq? (current-thread) (eventspace-handler-thread (get-eventspace))) + (send pref-save-canvas set-on? start?)] + [else + (queue-callback + (λ () + (send pref-save-canvas set-on? start?)))])))))) + (define/private (unregister-pref-save-callback) + (when pref-save-callback-registration + (preferences:unregister-save-callback pref-save-callback-registration))) + (register-pref-save-callback) + (unless (preferences:get 'framework:show-status-line) (send super-root change-children (λ (l) @@ -732,7 +761,7 @@ (let-values ([(cw _4) (get-client-size)] [(tw _1 _2 _3) (send dc get-text-extent str normal-control-font)]) (when (< cw tw) - (min-client-width (inexact->exact (floor tw))))))) + (min-client-width (inexact->exact (ceiling tw))))))) (define/override (on-paint) (let ([dc (get-dc)]) (send dc set-font normal-control-font) @@ -1693,15 +1722,22 @@ (define/augment (after-delete x y) (update-prefs) (inner (void) after-delete x y)) + (define timer #f) (define/private (update-prefs) - (preferences:set pref-sym - (let loop ([snip (find-first-snip)]) - (cond - [(not snip) '()] - [(is-a? snip string-snip%) - (cons (send snip get-text 0 (send snip get-count)) - (loop (send snip next)))] - [else (cons snip (loop (send snip next)))])))) + (unless timer + (set! timer (new timer% + [notify-callback + (λ () + (preferences:set pref-sym + (let loop ([snip (find-first-snip)]) + (cond + [(not snip) '()] + [(is-a? snip string-snip%) + (cons (send snip get-text 0 (send snip get-count)) + (loop (send snip next)))] + [else (cons snip (loop (send snip next)))]))))]))) + (send timer stop) + (send timer start 150 #t)) (define/override (get-keymaps) (editor:add-after-user-keymap search/replace-keymap (super get-keymaps))) (super-new) @@ -1807,7 +1843,7 @@ [bt (box 0)] [bb (box 0)]) (send text get-visible-line-range bt bb #f) - (unless (<= (unbox bt) search-result-line (unbox bb)) + (unless (< (unbox bt) search-result-line (unbox bb)) (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] [last-pos (send text position-line (send text last-position))] [top-pos (send text line-start-position @@ -2408,14 +2444,16 @@ (define/override (get-editor%) (text:searching-mixin (super get-editor%))) (super-new))) -(define memory-canvases '()) -(define show-memory-text? +(define checkout-or-nightly? (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (directory-exists? (collection-path "repo-time-stamp"))) (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (let ([fw (collection-path "framework")]) (directory-exists? (build-path fw 'up 'up ".git")))))) +(define memory-canvases '()) +(define show-memory-text? checkout-or-nightly?) + (define bday-click-canvas% (class canvas% (define/override (on-event evt) @@ -2427,6 +2465,33 @@ [else (super on-event evt)])) (super-new))) +(define pref-save-canvas% + (class canvas% + (define on? #f) + (define indicator "P") + (define/override (on-paint) + (cond + [on? + (let-values ([(cw ch) (get-client-size)]) + (send (get-dc) draw-text indicator + (- (/ cw 2) (/ indicator-width 2)) + (- (/ ch 2) (/ indicator-height 2))))])) + (define/public (set-on? new-on?) + (set! on? new-on?) + (send (get-dc) erase) + (on-paint) + (flush)) + + (inherit get-dc flush get-client-size min-width) + (super-new [stretchable-width #f] + [style '(transparent)]) + + (send (get-dc) set-font small-control-font) + (define-values (indicator-width indicator-height) + (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)]) + (values tw th))) + (min-width (+ (inexact->exact (ceiling indicator-width)) 4)))) + (define basic% (register-group-mixin (basic-mixin frame%))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) diff --git a/collects/framework/private/gen-standard-menus.rkt b/collects/framework/private/gen-standard-menus.rkt index 120799bb..7e603022 100644 --- a/collects/framework/private/gen-standard-menus.rkt +++ b/collects/framework/private/gen-standard-menus.rkt @@ -125,7 +125,7 @@ (write-docs)) (define (write-docs) - (printf "writing to ~a~n" docs-menus.ss-filename) + (printf "writing to ~a\n" docs-menus.ss-filename) (call-with-output-file docs-menus.ss-filename (λ (port) (define (pop-out sexp) @@ -203,7 +203,7 @@ #:exists 'truncate)) (define (write-standard-menus.rkt) - (printf "writing to ~a~n" standard-menus.rkt-filename) + (printf "writing to ~a\n" standard-menus.rkt-filename) (call-with-output-file standard-menus.rkt-filename (λ (port) diff --git a/collects/framework/private/group.rkt b/collects/framework/private/group.rkt index 96bd61ff..81811652 100644 --- a/collects/framework/private/group.rkt +++ b/collects/framework/private/group.rkt @@ -30,6 +30,11 @@ (f menu) (old menu))))) + (define windows-menu-label + (case (system-type) + [(macosx) (string-constant windows-menu-label)] + [else (string-constant tabs-menu-label)])) + (define % (class object% @@ -47,8 +52,10 @@ (and menu-bar (let ([menus (send menu-bar get-items)]) (ormap (λ (x) - (if (string=? (string-constant windows-menu) - (send x get-plain-label)) + (if (or (string=? (string-constant windows-menu) + (send x get-plain-label)) + (string=? (string-constant tabs-menu) + (send x get-plain-label))) x #f)) menus))))) @@ -105,33 +112,34 @@ [parent menu] [callback (λ (x y) (let ([frame (send (send menu get-parent) get-frame)]) - (send frame maximize (not (send frame is-maximized?)))))])) - (instantiate menu:can-restore-menu-item% () - (label (string-constant bring-frame-to-front...)) - (parent menu) - (callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame)))) - (shortcut #\j)) - (instantiate menu:can-restore-menu-item% () - (label (string-constant most-recent-window)) - (parent menu) - (callback (λ (x y) (most-recent-window-to-front))) - (shortcut #\')) - (make-object separator-menu-item% menu) + (send frame maximize (not (send frame is-maximized?)))))]) + (instantiate menu:can-restore-menu-item% () + (label (string-constant bring-frame-to-front...)) + (parent menu) + (callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame)))) + (shortcut #\j)) + (instantiate menu:can-restore-menu-item% () + (label (string-constant most-recent-window)) + (parent menu) + (callback (λ (x y) (most-recent-window-to-front))) + (shortcut #\')) + (make-object separator-menu-item% menu)) (extra-windows-menus-proc menu) - (for-each - (λ (frame) - (let ([frame (frame-frame frame)]) - (make-object menu-item% - (regexp-replace* - #rx"&" - (gui-utils:trim-string (get-name frame) 200) - "&&") - menu - (λ (_1 _2) - (send frame show #t))))) - sorted/visible-frames)) + (when (eq? (system-type) 'macosx) + (for-each + (λ (frame) + (let ([frame (frame-frame frame)]) + (make-object menu-item% + (regexp-replace* + #rx"&" + (gui-utils:trim-string (get-name frame) 200) + "&&") + menu + (λ (_1 _2) + (send frame show #t))))) + sorted/visible-frames))) windows-menus))) ;; most-recent-window-to-front : -> void? diff --git a/collects/framework/private/handler.rkt b/collects/framework/private/handler.rkt index 04ddade5..3890f7eb 100644 --- a/collects/framework/private/handler.rkt +++ b/collects/framework/private/handler.rkt @@ -181,23 +181,43 @@ (let ([recently-opened-files (preferences:get 'framework:recently-opened-files/pos)]) - (for ([item (send menu get-items)]) (send item delete)) - - (for ([recent-list-item recently-opened-files]) - (let ([filename (car recent-list-item)]) + (unless (menu-items-still-same? recently-opened-files menu) + (for ([item (send menu get-items)]) (send item delete)) + + (for ([recent-list-item recently-opened-files]) (new menu-item% - [parent menu] - [label (gui-utils:trim-string - (regexp-replace* #rx"&" (path->string filename) "\\&\\&") - 200)] - [callback (λ (x y) (open-recent-list-item recent-list-item))]))) - (new separator-menu-item% [parent menu]) - (new menu-item% - [parent menu] - [label (string-constant show-recent-items-window-menu-item)] - [callback (λ (x y) (show-recent-items-window))]) + [parent menu] + [label (recent-list-item->menu-label recent-list-item)] + [callback (λ (x y) (open-recent-list-item recent-list-item))])) + (new separator-menu-item% [parent menu]) + (new menu-item% + [parent menu] + [label (string-constant show-recent-items-window-menu-item)] + [callback (λ (x y) (show-recent-items-window))])) (void))) +(define (recent-list-item->menu-label recent-list-item) + (let ([filename (car recent-list-item)]) + (gui-utils:trim-string + (regexp-replace* #rx"&" (path->string filename) "\\&\\&") + 200))) + +;; this function must mimic what happens in install-recent-items +;; it returns #t if all of the labels of menus are the same, or approximation to +;; the menus actually being different +(define (menu-items-still-same? recently-opened-files menu) + (let ([current-items + (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) + (send menu get-items))] + ;; the new-items variable shoudl match up to what install-recent-items actually does when it creates the menu + [new-items + (append + (for/list ([recent-list-item recently-opened-files]) + (recent-list-item->menu-label recent-list-item)) + (list #f + (string-constant show-recent-items-window-menu-item)))]) + (equal? current-items new-items))) + ;; open-recent-list-item : recent-list-item -> void (define (open-recent-list-item recent-list-item) (let* ([filename (car recent-list-item)] diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index acfbe10d..905f311a 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -7,6 +7,7 @@ mzlib/match "../preferences.ss" mrlib/tex-table + (only-in srfi/13 string-prefix? string-prefix-length) "sig.ss") (import mred^ @@ -984,17 +985,32 @@ [TeX-compress (let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))]) + (define (meet s t) + (substring s 0 (string-prefix-length s t 0))) (λ (text event) (let ([pos (send text get-start-position)]) (when (= pos (send text get-end-position)) (let ([slash (send text find-string "\\" 'backward pos (max 0 (- pos biggest 1)))]) (when slash - (let ([to-replace (assoc (send text get-text slash pos) tex-shortcut-table)]) - (when to-replace - (send text begin-edit-sequence) - (send text delete (- slash 1) pos) - (send text insert (cadr to-replace)) - (send text end-edit-sequence)))))))))] + (define entered (send text get-text slash pos)) + (define completions + (filter (λ (shortcut) (string-prefix? entered (first shortcut))) + tex-shortcut-table)) + (unless (empty? completions) + (define-values (replacement partial?) + (let ([complete-match + (findf (λ (shortcut) (equal? entered (first shortcut))) + completions)]) + (if complete-match + (values (second complete-match) #f) + (if (= 1 (length completions)) + (values (second (first completions)) #f) + (let ([tex-names (map first completions)]) + (values (foldl meet (first tex-names) (rest tex-names)) #t)))))) + (send text begin-edit-sequence) + (send text delete (if partial? slash (- slash 1)) pos) + (send text insert replacement) + (send text end-edit-sequence))))))))] [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]) ;; don't have a capital ς, just comes out as \u03A2 (or junk) @@ -1214,7 +1230,8 @@ (map "del" "delete-key") (map-meta "d" "kill-word") - (map-meta "del" "backward-kill-word") + (map-meta "del" "kill-word") + (map-meta "backspace" "backward-kill-word") (map-meta "c" "capitalize-word") (map-meta "u" "upcase-word") (map-meta "l" "downcase-word") diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 893c5de6..ab94bf35 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -76,7 +76,7 @@ '("local") (λ (x) (and (list? x) (andmap string? x)))) (preferences:set-default 'framework:square-bracket:letrec - (let ([fors '("for" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")]) + (let ([fors '("for" "for/fold" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")]) (append fors (map (λ (x) (regexp-replace #rx"for" x "for*")) fors) @@ -208,7 +208,10 @@ (let ([hash-table (make-hasheq)]) (for-each (λ (x) (hash-set! hash-table x 'define)) - '(struct local)) + '(struct + local + + define-type)) (for-each (λ (x) (hash-set! hash-table x 'begin)) '(case-lambda @@ -261,9 +264,11 @@ parameterize call-with-input-file call-with-input-file* with-input-from-file with-input-from-port call-with-output-file - with-output-to-file with-output-to-port + with-output-to-file with-output-to-port for-all + + type-case )) (preferences:set-default 'framework:tabify diff --git a/collects/framework/private/panel.rkt b/collects/framework/private/panel.rkt index cfadd9d6..270eb3b4 100644 --- a/collects/framework/private/panel.rkt +++ b/collects/framework/private/panel.rkt @@ -44,7 +44,7 @@ [(left top) 0] [(right bottom) (- total-size item-size)] [else (error 'place-children - "alignment spec is unknown ~a~n" spec)])))]) + "alignment spec is unknown ~a\n" spec)])))]) (map (λ (l) (let*-values ([(min-width min-height h-stretch? v-stretch?) (apply values l)] @@ -182,9 +182,15 @@ (define dragable-mixin (mixin (window<%> area-container<%>) (dragable<%>) (init parent) - - (define/public (get-vertical?) - (error 'get-vertical "abstract method")) + + (init-field vertical?) + + (define/public-final (get-vertical?) vertical?) + (define/public-final (set-orientation h?) + (define v? (not h?)) + (unless (eq? vertical? v?) + (set! vertical? v?) + (container-flow-modified))) (define/private (min-extent child) (let-values ([(w h) (send child get-graphical-min-size)]) (if (get-vertical?) @@ -413,18 +419,15 @@ (stretchable-height #f) (min-height 10))) - (define vertical-dragable-mixin (mixin (dragable<%>) (vertical-dragable<%>) - (define/override (get-vertical?) #t) - (super-instantiate ()))) + (super-new [vertical? #t]))) (define horizontal-dragable-mixin (mixin (dragable<%>) (vertical-dragable<%>) - (define/override (get-vertical?) #f) - (super-instantiate ()))) + (super-new [vertical? #f]))) - (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%))) + (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin panel%))) - (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%))) + (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 03de7025..2d18ffba 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -206,13 +206,14 @@ the state transitions / contracts are: (define (make-preferences-dialog) (letrec ([stashed-prefs (preferences:get-prefs-snapshot)] - [cancelled? #t] + [cancelled? #f] [frame-stashed-prefs% (class frame:basic% (inherit close) (define/override (on-subwindow-char receiver event) (cond [(eq? 'escape (send event get-key-code)) + (set! cancelled? #t) (close)] [else (super on-subwindow-char receiver event)])) @@ -222,7 +223,7 @@ the state transitions / contracts are: (define/override (show on?) (when on? ;; reset the flag and save new prefs when the window becomes visible - (set! cancelled? #t) + (set! cancelled? #f) (set! stashed-prefs (preferences:get-prefs-snapshot))) (super show on?)) (super-new))] @@ -280,9 +281,10 @@ the state transitions / contracts are: (for-each (λ (f) (f)) on-close-dialog-callbacks) - (set! cancelled? #f) (send frame close)))] - [cancel-callback (λ () (send frame close))]) + [cancel-callback (λ () + (set! cancelled? #t) + (send frame close))]) (new button% [label (string-constant revert-to-defaults)] [callback @@ -293,7 +295,9 @@ the state transitions / contracts are: (gui-utils:ok/cancel-buttons bottom-panel ok-callback - (λ (a b) (cancel-callback))) + (λ (a b) (cancel-callback)) + (string-constant ok) + (string-constant undo-changes)) (make-object grow-box-spacer-pane% bottom-panel) (send* bottom-panel (stretchable-height #f) @@ -454,8 +458,10 @@ the state transitions / contracts are: 'framework:autosaving-on? (string-constant auto-save-files) values values) - (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) + (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) + ;; does this not belong here? + ;; (make-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers) (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) (make-check editor-panel 'framework:display-line-numbers @@ -528,18 +534,7 @@ the state transitions / contracts are: (cond [(string? default) string?] [(number? default) number?] - [else (error 'internal-error.set-default "unrecognized default: ~a~n" default)])) - (preferences:add-callback - name - (λ (p new-value) - (write-resource - font-section - font-entry - (if (and (string? new-value) - (string=? font-default-string new-value)) - "" - new-value) - font-file))))))]) + [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])))))]) (for-each (set-default build-font-entry font-default-string string?) font-families) @@ -577,14 +572,7 @@ the state transitions / contracts are: [message (make-object message% (let ([b (box "")]) - (if (and (get-resource - font-section - (build-font-entry name) - b) - (not (string=? (unbox b) - ""))) - (unbox b) - font-default-string)) + font-default-string) horiz)] [button (make-object button% @@ -641,11 +629,7 @@ the state transitions / contracts are: [size-panel (make-object horizontal-panel% main '(border))] [initial-font-size (let ([b (box 0)]) - (if (get-resource font-section - font-size-entry - b) - (unbox b) - font-default-size))] + font-default-size)] [size-slider (make-object slider% (string-constant font-size-slider-label) diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index f704fde9..e9da20f0 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -10,7 +10,8 @@ "collapsed-snipclass-helpers.ss" "sig.ss" "../gui-utils.ss" - "../preferences.ss") + "../preferences.ss" + scheme/match) (import mred^ [prefix preferences: framework:preferences^] @@ -43,13 +44,16 @@ (let* ([end (or in-end (send text last-position))] [port (open-input-text-editor text start end)]) (with-handlers ([exn:fail:read:eof? (λ (x) #f)] - [exn:fail:read? (λ (x) #f)]) + [exn:fail:read? (λ (x) #t)]) (let ([first (read port)]) - (and (not (eof-object? first)) - (let loop () - (let ([s (read port)]) - (or (eof-object? s) - (loop)))))))))) + (cond + [(eof-object? first) #f] + [else + (let loop () + (let ([s (read port)]) + (cond + [(eof-object? s) #t] + [else (loop)])))])))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -200,7 +204,8 @@ (let ([up-sexp (send text find-up-sexp click-pos)]) (when up-sexp (let ([fwd (send text get-forward-sexp up-sexp)]) - (make-collapse-item text up-sexp fwd menu))))])))) + (when fwd + (make-collapse-item text up-sexp fwd menu)))))])))) ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void (define (make-expand-item text snip menu) @@ -316,10 +321,10 @@ (define (short-sym->style-name sym) (hash-ref sn-hash sym (λ () - (let ([s (format "framework:syntax-color:scheme:~a" - (xlate-sym-style sym))]) - (hash-set! sn-hash sym s) - s)))) + (let ([s (format "framework:syntax-color:scheme:~a" + (xlate-sym-style sym))]) + (hash-set! sn-hash sym s) + s)))) (define (add-coloring-preferences-panel) (color-prefs:add-to-preferences-panel @@ -373,7 +378,8 @@ introduce-let-ans move-sexp-out - kill-enclosing-parens)) + kill-enclosing-parens + toggle-round-square-parens)) (define init-wordbreak-map (λ (map) @@ -1051,16 +1057,43 @@ (let ([begin-outer (find-up-sexp begin-inner)]) (cond [begin-outer - (let ([end-outer (get-forward-sexp begin-outer)]) - (cond - [(and end-outer (> (- end-outer begin-outer) 2)) - (delete (- end-outer 1) end-outer) - (delete begin-outer (+ begin-outer 1)) - (tabify-selection begin-outer (- end-outer 2))] - [else (bell)]))] + (let ([end-outer (get-forward-sexp begin-outer)]) + (cond + [(and end-outer (> (- end-outer begin-outer) 2)) + (delete (- end-outer 1) end-outer) + (delete begin-outer (+ begin-outer 1)) + (tabify-selection begin-outer (- end-outer 2))] + [else (bell)]))] [else (bell)])) (end-edit-sequence)) + ;; change the parens following the cursor from () to [] or vice versa + (define/public (toggle-round-square-parens start-pos) + (begin-edit-sequence) + (let* ([sexp-begin (skip-whitespace start-pos 'forward #f)] + [sexp-end (get-forward-sexp sexp-begin)]) + (cond [(and sexp-end + (< (+ 1 sexp-begin) sexp-end)) + ;; positions known to exist: start-pos <= x < sexp-end + (match* ((get-character sexp-begin) (get-character (- sexp-end 1))) + [(#\( #\)) (replace-char-at-posn sexp-begin "[") + (replace-char-at-posn (- sexp-end 1) "]")] + [(#\[ #\]) (replace-char-at-posn sexp-begin "(") + (replace-char-at-posn (- sexp-end 1) ")")] + [(_ _) (bell)])] + [else (bell)])) + (end-edit-sequence)) + + ;; replace-char-at-posn: natural-number string -> + ;; replace the char at the given posn with the given string. + ;; + ;; this abstraction exists because the duplicated code in toggle-round-square-parens was + ;; just a little too much for comfort + (define (replace-char-at-posn posn str) + ;; insertions are performed before deletions in order to preserve the location of the cursor + (insert str (+ posn 1) (+ posn 1)) + (delete posn (+ posn 1))) + (inherit get-fixed-style) (define/public (mark-matching-parenthesis pos) (let ([open-parens (map car (scheme-paren:get-paren-pairs))] @@ -1187,7 +1220,7 @@ (define/override (put-file text sup directory default-name) (parameterize ([finder:default-extension "rkt"] - [finder:default-filters '(["Racket Sources" "*.rkt;*.ss;*.scm"] + [finder:default-filters '(["Racket Sources" "*.rkt;*.scrbl;*.ss;*.scm"] ["Any" "*.*"])]) ;; don't call the surrogate's super, since it sets the default extension (sup directory default-name))) @@ -1255,6 +1288,8 @@ (λ (e p) (send e move-sexp-out p))) (add-pos-function "kill-enclosing-parens" (lambda (e p) (send e kill-enclosing-parens p))) + (add-pos-function "toggle-round-square-parens" + (lambda (e p) (send e toggle-round-square-parens p))) (let ([add-edit-function (λ (name call-method) @@ -1381,7 +1416,8 @@ (send keymap map-function "c:c;c:b" "remove-parens-forward") (send keymap map-function "c:c;c:l" "introduce-let-ans") (send keymap map-function "c:c;c:o" "move-sexp-out") - (send keymap map-function "c:c;c:e" "kill-enclosing-parens"))) + (send keymap map-function "c:c;c:e" "kill-enclosing-parens") + (send keymap map-function "c:c;c:[" "toggle-round-square-parens"))) (define keymap (make-object keymap:aug-keymap%)) (setup-keymap keymap) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 48f83b6c..702b0178 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -163,6 +163,7 @@ (define-signature text-class^ (basic<%> first-line<%> + line-numbers<%> foreground-color<%> hide-caret/selection<%> nbsp->space<%> @@ -199,6 +200,7 @@ basic-mixin first-line-mixin + line-numbers-mixin foreground-color-mixin hide-caret/selection-mixin nbsp->space-mixin diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9fd0cbc9..63d514e0 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,12 +11,13 @@ WARNING: printf is rebound in the body of the unit to always scheme/class scheme/match scheme/path - "sig.ss" - "../gui-utils.ss" - "../preferences.ss" + "sig.rkt" + "../gui-utils.rkt" + "../preferences.rkt" mred/mred-sig mrlib/interactive-value-port setup/dirs + racket/list (prefix-in srfi1: srfi/1)) (require setup/xref scribble/xref @@ -144,98 +145,45 @@ WARNING: printf is rebound in the body of the unit to always (send (get-style-list) find-named-style "Standard")) (define/private (invalidate-rectangles rectangles) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [canvases (get-canvases)]) - (let-values ([(min-left max-right) - (cond - [(null? canvases) - (let ([admin (get-admin)]) - (if admin - (begin - (send admin get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))) - (values #f #f)))] - [else - (let loop ([left #f] - [right #f] - [canvases canvases]) - (cond - [(null? canvases) - (values left right)] - [else - (let-values ([(this-left this-right) - (send (car canvases) - call-as-primary-owner - (λ () - (send (get-admin) get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))))]) - (if (and left right) - (loop (min this-left left) - (max this-right right) - (cdr canvases)) - (loop this-left - this-right - (cdr canvases))))]))])]) - (when (and min-left max-right) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles] - [refresh? #f]) - (cond - [(null? rectangles) - (when left - (let ([width (- right left)] - [height (- bottom top)]) - (when refresh? - (for-each (λ (canvas) (send canvas refresh)) - canvases)) - (when (and (> width 0) - (> height 0)) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - - [adjust (λ (w f) - (+ w (f (case (rectangle-style r) - [(dot hollow-ellipse) 8] - [else 0]))))] - [this-left (if (number? (rectangle-left r)) - (adjust (rectangle-left r) -) - min-left)] - [this-right (if (number? (rectangle-right r)) - (adjust (rectangle-right r) +) - max-right)] - [this-top (adjust (rectangle-top r) -)] - [this-bottom (adjust (rectangle-bottom r) +)]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles) - (or refresh? - (not (number? (rectangle-left r))) - (not (number? (rectangle-right r))))) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles) - (or refresh? - (not (number? (rectangle-left r))) - (not (number? (rectangle-right r)))))))])))))) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (let ([width (if (number? right) (- right left) 'display-end)] + [height (if (number? bottom) (- bottom top) 'display-end)]) + (when (and (or (symbol? width) (> width 0)) + (or (symbol? height) (> height 0))) + (invalidate-bitmap-cache left top width height))))] + [else (let* ([r (car rectangles)] + [adjust (λ (w f) + (+ w (f (case (rectangle-style r) + [(dot hollow-ellipse) 8] + [else 0]))))] + [this-left (if (number? (rectangle-left r)) + (adjust (rectangle-left r) -) + 0.0)] + [this-right (if (number? (rectangle-right r)) + (adjust (rectangle-right r) +) + 'display-end)] + [this-top (adjust (rectangle-top r) -)] + [this-bottom (adjust (rectangle-bottom r) +)]) + (if (and left top right bottom) + (loop (min this-left left) + (min this-top top) + (if (and (number? this-right) (number? right)) + (max this-right right) + 'display-end) + (max this-bottom bottom) + (cdr rectangles)) + (loop this-left + this-top + this-right + this-bottom + (cdr rectangles))))]))) (define/private (recompute-range-rectangles) (let* ([b1 (box 0)] @@ -3749,3 +3697,257 @@ designates the character that triggers autocompletion (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) (define searching% (searching-mixin backup-autosave%)) (define info% (info-mixin (editor:info-mixin searching%))) + +;; ============================================================ +;; line number text% + +(define line-numbers<%> + (interface () + show-line-numbers! + showing-line-numbers? + set-line-numbers-color)) + +;; draws line numbers on the left hand side of a text% object +(define line-numbers-mixin + (mixin ((class->interface text%)) (line-numbers<%>) + (super-new) + (inherit get-visible-line-range + get-visible-position-range + last-line + line-location + line-paragraph + line-start-position + line-end-position) + + (init-field [line-numbers-color "black"]) + (init-field [show-line-numbers? #t]) + ;; whether the numbers are aligned on the left or right + ;; only two values should be 'left or 'right + (init-field [alignment 'right]) + + (define (number-space) + (number->string (max (* 10 (add1 (last-line))) 100))) + ;; add an extra 0 so it looks nice + (define (number-space+1) (string-append (number-space) "0")) + + (define cached-snips (list)) + (define need-to-recalculate-snips #f) + + ;; call this method with #t or #f to turn on/off line numbers + (define/public (show-line-numbers! what) + (set! show-line-numbers? what)) + + (define/public (showing-line-numbers?) + show-line-numbers?) + + (define/public (set-line-numbers-color color) + (set! line-numbers-color color)) + + (define (get-style-font) + (let* ([style-list (send this get-style-list)] + [std (or (send style-list find-named-style "Standard") + #t + #; + (send style-list basic-style))]) + (send std get-font))) + + ;; a <= b <= c + (define (between low what high) + (and (>= what low) + (<= what high))) + + (define-struct saved-dc-state (pen font foreground-color)) + (define (save-dc-state dc) + (saved-dc-state (send dc get-pen) + (send dc get-font) + (send dc get-text-foreground))) + + (define (restore-dc-state dc dc-state) + (send dc set-pen (saved-dc-state-pen dc-state)) + (send dc set-font (saved-dc-state-font dc-state)) + (send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) + + ;; set the dc stuff to values we want + (define (setup-dc dc) + (send dc set-pen "black" 1 'solid) + (send dc set-font (get-style-font)) + (send dc set-text-foreground (make-object color% line-numbers-color))) + + (define (lighter-color color) + (define (integer number) + (inexact->exact (round number))) + ;; hue 0-360 + ;; saturation 0-1 + ;; lightness 0-1 + ;; returns rgb as float values with ranges 0-1 + (define (hsl->rgb hue saturation lightness) + (define (helper x a b) + (define x* (cond + [(< x 0) (+ x 1)] + [(> x 1) (- x 1)] + [else x])) + (cond + [(< (* x 6) 1) (+ b (* 6 (- a b) x))] + [(< (* x 6) 3) a] + [(< (* x 6) 4) (+ b (* (- a b) (- 4 (* 6 x))))] + [else b])) + + (define h (/ hue 360)) + (define a (if (< lightness 0.5) + (+ lightness (* lightness saturation)) + (- (+ lightness saturation) (* lightness saturation)))) + (define b (- (* lightness 2) a)) + (define red (helper (+ h (/ 1.0 3)) a b)) + (define green (helper h a b)) + (define blue (helper (- h (/ 1.0 3)) a b)) + (values red green blue)) + + ;; red 0-255 + ;; green 0-255 + ;; blue 0-255 + (define (rgb->hsl red green blue) + (define-values (a b c d) + (if (> red green) + (if (> red blue) + (if (> green blue) + (values red (- green blue) blue 0) + (values red (- green blue) green 0)) + (values blue (- red green) green 4)) + (if (> red blue) + (values green (- blue red) blue 2) + (if (> green blue) + (values green (- blue red) red 2) + (values blue (- red green) red 4))))) + (define hue (if (= a c) 0 + (let ([x (* 60 (+ d (/ b (- a c))))]) + (if (< x 0) (+ x 360) x)))) + (define saturation (cond + [(= a c) 0] + [(< (+ a c) 1) (/ (- a c) (+ a c))] + [else (/ (- a c) (- 2 a c))])) + (define lightness (/ (+ a c) 2)) + (values hue saturation lightness)) + (define-values (hue saturation lightness) + (rgb->hsl (send color red) + (send color green) + (send color blue))) + (define-values (red green blue) + (hsl->rgb hue saturation (+ 0.5 lightness))) + (make-object color% (min 255 (integer (* 255 red))) + (min 255 (integer (* 255 green))) + (min 255 (integer (* 255 blue))))) + + (define (draw-numbers dc top bottom dx dy start-line end-line) + (define (draw-text . args) + (send/apply dc draw-text args)) + + (define right-space (text-width dc (number-space))) + (define single-space (text-width dc "0")) + + (define last-paragraph #f) + (for ([line (in-range start-line end-line)]) + (define y (line-location line)) + + (when (between top y bottom) + (define view (number->string (add1 (line-paragraph line)))) + (define final-x + (+ dx + (case alignment + [(left) 0] + [(right) (- right-space (text-width dc view) single-space)] + [else 0]))) + (define final-y (+ dy y)) + (if (and last-paragraph (= last-paragraph (line-paragraph line))) + (begin + (send dc set-text-foreground (lighter-color (send dc get-text-foreground))) + (draw-text view final-x final-y) + (send dc set-text-foreground (make-object color% line-numbers-color))) + (draw-text view final-x final-y))) + + (set! last-paragraph (line-paragraph line)))) + + ;; draw the line between the line numbers and the actual text + (define (draw-separator dc top bottom dx dy x) + (send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom))) + + ;; `line-numbers-space' will get mutated in the `on-paint' method + (define line-numbers-space 0) + (define/override (find-position x y . args) + ;; adjust x position to account for line numbers + (if show-line-numbers? + (super find-position (- x line-numbers-space) y . args) + (super find-position x y . args))) + + (define (draw-line-numbers dc left top right bottom dx dy) + (define saved-dc (save-dc-state dc)) + (setup-dc dc) + (define start-line (box 0)) + (define end-line (box 0)) + (get-visible-line-range start-line end-line #f) + + ;; draw it! + (draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) + (draw-separator dc top bottom dx dy (text-width dc (number-space))) + (restore-dc-state dc saved-dc)) + + (define (text-width dc stuff) + (define-values (font-width font-height baseline space) + (send dc get-text-extent stuff)) + font-width) + + (define (text-height dc stuff) + (define-values (font-width height baseline space) + (send dc get-text-extent stuff)) + height) + + (define old-origin-x 0) + (define old-origin-y 0) + (define old-clipping #f) + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (when show-line-numbers? + (if before? + (let () + ;; FIXME: Moving the origin and setting the clipping rectangle + ;; will probably go away when 'margin's are added to editors + ;; + ;; save old origin and push it to the right a little bit + ;; TODO: maybe allow the line numbers to be drawn on the right hand side + ;; of the editor? + (define-values (x y) (send dc get-origin)) + (set! old-origin-x x) + (set! old-origin-y y) + (set! old-clipping (send dc get-clipping-region)) + (define saved-dc (save-dc-state dc)) + (setup-dc dc) + (define-values (font-width font-height baseline space) + (send dc get-text-extent (number-space))) + (restore-dc-state dc saved-dc) + (define clipped (make-object region% dc)) + (define all (make-object region% dc)) + (define copy (make-object region% dc)) + (send all set-rectangle + (+ dx left) (+ dy top) + (- right left) (- bottom top)) + (if old-clipping + (send copy union old-clipping) + (send copy union all)) + (send clipped set-rectangle + 0 (+ dy top) + (text-width dc (number-space+1)) + (- bottom top)) + #; + (define (print-region name region) + (define-values (a b c d) (send region get-bounding-box)) + (printf "~a: ~a, ~a, ~a, ~a\n" name a b c d)) + (send copy subtract clipped) + (send dc set-clipping-region copy) + (send dc set-origin (+ x (text-width dc (number-space+1))) y) + (set! line-numbers-space (text-width dc (number-space+1))) + ) + (begin + ;; rest the origin and draw the line numbers + (send dc set-origin old-origin-x old-origin-y) + (send dc set-clipping-region old-clipping) + (draw-line-numbers dc left top right bottom dx dy)))) + (super on-paint before? dc left top right bottom dx dy draw-caret)) + )) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index f2908f25..016b149a 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -14,7 +14,7 @@ shutdown-splash close-splash add-splash-icon - set-splash-progress-bar? + set-splash-progress-bar?! set-splash-char-observer set-splash-event-callback get-splash-event-callback @@ -72,8 +72,8 @@ (splash-paint-callback dc)] [else (splash-paint-callback dc - (send gauge get-value) - (send gauge get-range) + (send (get-gauge) get-value) + (send (get-gauge) get-range) (get-splash-width) (get-splash-height))]) (for-each (λ (icon) @@ -86,9 +86,9 @@ (send (icon-bm icon) get-loaded-mask))) icons)) -(define (set-splash-progress-bar? b?) +(define (set-splash-progress-bar?! b?) (send gauge-panel change-children - (λ (l) (if b? (list gauge) '())))) + (λ (l) (if b? (list (get-gauge)) '())))) (define (splash-paint-callback dc) (if splash-bitmap @@ -107,10 +107,11 @@ (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 #:allow-funny? [allow-funny? #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))) - (send gauge set-range splash-max-width) + (send (get-gauge) set-range splash-max-width) (send splash-tlw set-label splash-title) (let/ec k (define (no-splash) @@ -123,12 +124,12 @@ [(or (path? splash-draw-spec) (string? splash-draw-spec)) (unless (file-exists? splash-draw-spec) - (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec) + (fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec) (no-splash)) (set! splash-bitmap (make-object bitmap% splash-draw-spec)) (unless (send splash-bitmap ok?) - (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec) + (fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec) (no-splash)) (send splash-canvas min-width (send splash-bitmap get-width)) @@ -156,6 +157,7 @@ (refresh-splash) (send splash-tlw center 'both) (thread (λ () (send splash-tlw show #t))) + (sync (system-idle-evt)) ; try to wait for dialog to be shown (flush-display) (yield) (sleep) (flush-display) (yield) (sleep))) @@ -188,8 +190,8 @@ (define (splash-load-handler old-load f expected) (set! splash-current-width (+ splash-current-width 1)) (when (<= splash-current-width splash-max-width) - (send gauge set-value splash-current-width) - (when (or (not (member gauge (send gauge-panel get-children))) + (send (get-gauge) set-value splash-current-width) + (when (or (not (member (get-gauge) (send gauge-panel get-children))) ;; when the gauge is not visible, we'll redraw the canvas (refresh-splash-on-gauge-change? splash-current-width splash-max-width)) (refresh-splash))) @@ -218,7 +220,9 @@ (equal? (getenv "PLTDRDEBUG") "trace")) (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n") (manager-trace-handler - (λ (x) (display "2: ") (display x) (newline)))))) + (λ (x) + (when (regexp-match #rx"compiling" x) + (display "2: ") (display x) (newline))))))) (define funny-gauge% (class canvas% @@ -226,7 +230,7 @@ (field [funny-value 0] [funny-bitmap - (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] + (make-object bitmap% (collection-file-path "touch.bmp" "icons"))] [max-value 1]) (define/public (get-range) max-value) @@ -284,7 +288,7 @@ (define/augment (on-close) (when quit-on-close? (exit))) - (super-new))) + (super-new [style '(close-button)]))) (define splash-canvas% (class canvas% @@ -303,10 +307,15 @@ (define panel (make-object vertical-pane% splash-tlw)) (define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)])) (define gauge-panel (make-object horizontal-pane% panel)) -(define gauge - (if funny? - (make-object funny-gauge% gauge-panel) - (make-object gauge% #f splash-max-width gauge-panel '(horizontal)))) +(define get-gauge + (let ([gauge #f]) + (λ () + (unless gauge + (set! gauge + (if funny? + (make-object funny-gauge% gauge-panel) + (make-object gauge% #f splash-max-width gauge-panel '(horizontal))))) + gauge))) (send panel stretchable-width #f) (send panel stretchable-height #f) (send gauge-panel set-alignment 'center 'top) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 03f49d35..cfad76ac 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -363,7 +363,7 @@ (loop (- n 1))))])))] [(number? state) (unless (send rb is-enabled? state) - (error 'test:set-radio-box! "item ~a is not enabled~n" state)) + (error 'test:set-radio-box! "item ~a is not enabled\n" state)) (send rb set-selection state)] [else (error 'test:set-radio-box! "expected a string or a number as second arg, got: ~e (other arg: ~e)" @@ -466,7 +466,8 @@ 'noalt 'nocontrol 'nometa 'noshift)) (define valid-key-symbols - (list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital + (list 'escape ;; just trying this for the heck of it -- JBC, 2010-08-13 + 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital 'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print 'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2 'numpad3 'numpad4 'numpad5 'numpad6 'numpad7 'numpad8 'numpad9 diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 23d0fef9..0b5efef1 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -1,4 +1,3 @@ - #lang scheme/signature add-color<%> @@ -38,8 +37,6 @@ control<%> current-eventspace current-eventspace-has-menu-root? current-eventspace-has-standard-menus? -current-ps-afm-file-paths -current-ps-cmap-file-paths current-ps-setup current-text-keymap-initializer cursor% @@ -91,7 +88,8 @@ get-font-from-user get-page-setup-from-user get-panel-background get-ps-setup-from-user -get-resource +get-highlight-background-color +get-highlight-text-color get-text-from-user get-the-editor-data-class-list get-the-snip-class-list @@ -117,9 +115,13 @@ label->plain-label labelled-menu-item<%> list-box% list-control<%> +make-bitmap make-eventspace +make-gl-bitmap make-gui-empty-namespace make-gui-namespace +make-monochrome-bitmap +make-screen-bitmap map-command-as-meta-key menu% menu-bar% @@ -141,6 +143,7 @@ open-output-text-editor pane% panel% pasteboard% +pdf-dc% pen% pen-list% play-sound @@ -153,6 +156,7 @@ put-file queue-callback radio-box% readable-snip<%> +read-bitmap read-editor-global-footer read-editor-global-header read-editor-version @@ -160,7 +164,6 @@ region% register-collecting-blit scroll-event% selectable-menu-item<%> -send-event send-message-to-window separator-menu-item% sleep/yield @@ -203,5 +206,4 @@ window<%> write-editor-global-footer write-editor-global-header write-editor-version -write-resource yield diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 3127506f..3c9e5ed1 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -4,6 +4,7 @@ namespace-anchor->empty-namespace make-base-empty-namespace) scheme/class + racket/draw mzlib/etc (prefix wx: "private/kernel.ss") (prefix wx: "private/wxme/style.ss") @@ -38,24 +39,10 @@ "private/gdi.ss" "private/snipfile.ss" "private/repl.ss" - "private/afm.ss" "private/helper.ss" "private/dynamic.ss" "private/check.ss") - ;; Initialize AFM/PS: - (wx:set-ps-procs - afm-draw-text - afm-get-text-extent - afm-expand-name - afm-glyph-exists? - afm-record-font - afm-fonts-string) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; These functions are re-implemented in scheme/gui/base ;; and racket/gui/base to attach those names, instead of @@ -115,34 +102,23 @@ add-pasteboard-keymap-functions begin-busy-cursor bell - bitmap% - brush% - brush-list% editor-data% editor-data-class% editor-data-class-list<%> check-for-break clipboard<%> clipboard-client% - color% - color-database<%> control-event% current-eventspace - current-ps-setup cursor% - dc<%> - dc-path% get-display-depth end-busy-cursor event% event-dispatch-handler eventspace? - find-graphical-system-path flush-display - font% - font-list% - font-name-directory<%> - get-resource + get-highlight-background-color + get-highlight-text-color get-the-editor-data-class-list get-the-snip-class-list image-snip% @@ -162,14 +138,9 @@ editor-wordbreak-map% mouse-event% mult-color<%> - pen% - pen-list% - point% - ps-setup% read-editor-global-footer read-editor-global-header read-editor-version - region% scroll-event% snip% snip-admin% @@ -187,24 +158,32 @@ write-editor-global-footer write-editor-global-header write-editor-version - write-resource queue-callback yield eventspace-shutdown? get-panel-background - send-event - gl-context<%> - gl-config%) - (define the-color-database (wx:get-the-color-database)) - (define the-font-name-directory (wx:get-the-font-name-directory)) + the-style-list + the-editor-wordbreak-map + make-screen-bitmap + make-gl-bitmap) + (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) - (define the-font-list (wx:get-the-font-list)) - (define the-pen-list (wx:get-the-pen-list)) - (define the-brush-list (wx:get-the-brush-list)) - (define the-style-list wx:the-style-list) - (define the-editor-wordbreak-map wx:the-editor-wordbreak-map) + + (define (find-graphical-system-path what) + (unless (memq what '(init-file x-display)) + (raise-type-error 'find-graphical-system-path "'init-file or 'x-display" what)) + (or (wx:find-graphical-system-path what) + (case what + [(init-file) + (build-path (find-system-path 'init-dir) + (case (system-type) + [(windows) "gracketrc.rktl"] + [else ".gracketrc"]))] + [else #f]))) + + (provide (all-from racket/draw)) (provide button% canvas% @@ -276,29 +255,19 @@ get-display-left-top-inset get-color-from-user get-font-from-user - append-editor-operation-menu-items + append-editor-operation-menu-items append-editor-font-menu-items get-top-level-focus-window get-top-level-edit-target-window register-collecting-blit unregister-collecting-blit - bitmap-dc% - post-script-dc% printer-dc% current-text-keymap-initializer sleep/yield get-window-text-extent - get-family-builtin-face send-message-to-window the-clipboard the-x-selection-clipboard - the-editor-wordbreak-map - the-brush-list - the-color-database - the-font-name-directory - the-pen-list - the-font-list - the-style-list normal-control-font small-control-font tiny-control-font @@ -321,9 +290,8 @@ make-gui-namespace make-gui-empty-namespace file-creator-and-type - current-ps-afm-file-paths - current-ps-cmap-file-paths hide-cursor-until-moved system-position-ok-before-cancel? label-string? - key-code-symbol?)) + key-code-symbol? + find-graphical-system-path)) diff --git a/collects/mred/private/app.rkt b/collects/mred/private/app.rkt index ac3eaaa0..c546ae87 100644 --- a/collects/mred/private/app.rkt +++ b/collects/mred/private/app.rkt @@ -1,6 +1,6 @@ -(module app mzscheme - (require mzlib/class - (prefix wx: "kernel.ss") +(module app racket/base + (require racket/class + (prefix-in wx: "kernel.ss") "lock.ss" "helper.ss" "wx.ss" @@ -42,14 +42,15 @@ (dynamic-wind void (lambda () - (send af on-exit) + (as-exit (lambda () + (send af on-exit))) (unless (null? (wx:get-top-level-windows)) (wx:cancel-quit))) (lambda () (set! running-quit? #f)))))))))))]) (wx:application-quit-handler (make-app-handler f f))) - (define (set-handler! who proc param arity result-filter) + (define (set-handler! who proc param arity result-filter post-set) (when proc (unless (and (procedure? proc) (procedure-arity-includes? proc arity)) @@ -58,13 +59,14 @@ proc))) (let ([e (wx:current-eventspace)]) (when (wx:main-eventspace? e) - (param (make-app-handler + (param (make-app-handler (lambda args (parameterize ([wx:current-eventspace e]) (wx:queue-callback (lambda () (result-filter (apply proc args))) wx:middle-queue-key))) - proc))))) + proc)) + (post-set)))) (define application-preferences-handler (case-lambda @@ -74,7 +76,8 @@ (set-handler! 'application-preferences-handler proc wx:application-pref-handler 0 - values)])) + values + void)])) (define application-about-handler (case-lambda @@ -85,7 +88,8 @@ (set-handler! 'application-about-handler proc wx:application-about-handler 0 - values)])) + values + void)])) (define application-quit-handler (case-lambda @@ -96,18 +100,33 @@ (set-handler! 'application-quit-handler proc wx:application-quit-handler 0 - (lambda (v) (unless v (wx:cancel-quit)) v))])) + (lambda (v) (unless v (wx:cancel-quit)) v) + void)])) + + (define saved-files null) (define default-application-file-handler (entry-point (lambda (f) (let ([af (weak-box-value active-main-frame)]) - (when af - (queue-window-callback - af - (entry-point - (lambda () (when (send af accept-drag?) - (send af on-drop-file f)))))))))) + (if af + (queue-window-callback + af + (entry-point + (lambda () (if (send af accept-drag?) + (send af on-drop-file f) + (set! saved-files (cons f saved-files)))))) + (set! saved-files (cons f saved-files))))))) + + (define (requeue-saved-files) + (as-entry + (lambda () + (for-each (lambda (f) + (wx:queue-callback (lambda () + ((wx:application-file-handler) f)) + wx:middle-queue-key)) + (reverse saved-files)) + (set! saved-files null)))) (define (install-defh) (wx:application-file-handler (make-app-handler @@ -128,7 +147,8 @@ (set-handler! 'application-file-handler proc wx:application-file-handler 1 - values))])) + values + requeue-saved-files))])) (define (current-eventspace-has-standard-menus?) diff --git a/collects/mred/private/check.rkt b/collects/mred/private/check.rkt index 030901fd..717d099c 100644 --- a/collects/mred/private/check.rkt +++ b/collects/mred/private/check.rkt @@ -107,7 +107,7 @@ (define check-margin-integer (check-bounded-integer 0 1000 #f)) - (define check-gauge-integer (check-bounded-integer 1 10000 #f)) + (define check-gauge-integer (check-bounded-integer 1 1000000 #f)) (define (check-wheel-step cwho wheel-step) (when (and wheel-step diff --git a/collects/mred/private/const.rkt b/collects/mred/private/const.rkt index 7964d97a..8bf30879 100644 --- a/collects/mred/private/const.rkt +++ b/collects/mred/private/const.rkt @@ -60,11 +60,11 @@ (define black-color (make-object wx:color% 0 0 0)) (define disabled-color (make-object wx:color% 150 150 150)) - (define trans-pen (send (wx:get-the-pen-list) find-or-create-pen "white" 0 'transparent)) - (define light-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e1.35) 0 'solid)) - (define border-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.85) 0 'solid)) - (define dark-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.6) 0 'solid)) - (define dark-brush (send (wx:get-the-brush-list) find-or-create-brush (scale-color bg-color #e0.8) 'solid)) + (define trans-pen (send wx:the-pen-list find-or-create-pen "white" 0 'transparent)) + (define light-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e1.35) 0 'solid)) + (define border-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e0.85) 0 'solid)) + (define dark-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e0.6) 0 'solid)) + (define dark-brush (send wx:the-brush-list find-or-create-brush (scale-color bg-color #e0.8) 'solid)) (define wx-tab-group<%> (interface ())) (define wx-group-box<%> (interface ())) diff --git a/collects/mred/private/dynamic.rkt b/collects/mred/private/dynamic.rkt index 0ef4b128..0fd5c23f 100644 --- a/collects/mred/private/dynamic.rkt +++ b/collects/mred/private/dynamic.rkt @@ -6,6 +6,4 @@ (provide kernel-initialized) -(dynamic-require ''#%mred-kernel #f) - (define kernel-initialized 'done) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index a3d06564..a6f24eb0 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -17,17 +17,6 @@ put-file get-directory) - (define (files->list s) - (let ([s (open-input-bytes s)]) - (let loop () - (let ([n (read s)]) - (if (eof-object? n) - null - (begin - (read-byte s) ; drop space - (cons (read-bytes n s) - (loop)))))))) - (define (mk-file-selector who put? multi? dir?) (lambda (message parent directory filename extension style filters) ;; Calls from C++ have wrong kind of window: @@ -52,7 +41,7 @@ (raise-type-error who "list of 2-string lists" filters)) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) - (if (or std? (eq? (system-type) 'unix)) + (if std? (send (new path-dialog% [put? put?] [dir? dir?] @@ -66,23 +55,22 @@ [dir? #f] [else filters])]) run) - (let ([s (wx:file-selector - message directory filename extension - ;; file types: - (apply string-append - (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) - filters)) - ;; style: - (cons (cond [dir? 'dir] - [put? 'put] - [multi? 'multi] - [else 'get]) - style) - ;; parent: - (and parent (mred->wx parent)))]) - (if (and multi? s) - (map bytes->path (files->list (path->bytes s))) - s)))))) + (wx:file-selector + message directory filename extension + ;; file types: + filters + #; + (apply string-append + (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) + filters)) + ;; style: + (cons (cond [dir? 'dir] + [put? 'put] + [multi? 'multi] + [else 'get]) + style) + ;; parent: + (and parent (mred->wx parent))))))) (define default-filters '(("Any" "*.*"))) diff --git a/collects/mred/private/fontdialog.rkt b/collects/mred/private/fontdialog.rkt index 9e58232e..c8c37957 100644 --- a/collects/mred/private/fontdialog.rkt +++ b/collects/mred/private/fontdialog.rkt @@ -39,7 +39,7 @@ (let ([s (send (send edit get-style-list) find-named-style "Standard")]) (send s set-delta (font->delta f))))))] [p (make-object horizontal-pane% f)] - [face (make-object list-box% #f (get-face-list) p refresh-sample)] + [face (make-object list-box% #f (wx:get-face-list) p refresh-sample)] [p2 (make-object vertical-pane% p)] [p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])] [style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])]) @@ -52,7 +52,9 @@ [sip (make-object check-box% "Size in Pixels" p4 refresh-sample)] [sym (make-object check-box% "Map as Symbol" p4 refresh-sample)] [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)] - [sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))] + [sample (make-object text-field% "Sample" f void + "The quick brown fox jumped over the lazy dog\n(\u3bb (x) x)\n" + '(multiple))] [edit (send sample get-editor)] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [get-font (lambda () (let ([face (send face get-string-selection)]) @@ -71,7 +73,7 @@ [(3) 'unsmoothed]) (send sip get-value)))))] [bp (instantiate horizontal-pane% (f) [stretchable-height #f])] - [ms-button (if (eq? (system-type) 'windows) + [ms-button (if (eq? (wx:font-from-user-platform-mode) 'dialog) (begin0 (make-object button% "Use System Dialog..." bp (lambda (b e) @@ -96,7 +98,7 @@ (lambda (font) (let* ([facen (if font (send font get-face) - (get-family-builtin-face 'default))] + (wx:get-family-builtin-face 'default))] [f (and facen (send face find-string facen))]) (and f (>= f 0) (send face set-selection f))) (when font diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 6c7cdb59..89a847bb 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -6,22 +6,20 @@ "lock.ss" "check.ss" "wx.ss" + "te.rkt" "mrtop.ss" - "mrcanvas.ss") + "mrcanvas.ss" + "syntax.rkt") (provide register-collecting-blit unregister-collecting-blit - bitmap-dc% - post-script-dc% printer-dc% get-window-text-extent - get-family-builtin-face normal-control-font small-control-font tiny-control-font view-control-font - menu-control-font - get-face-list) + menu-control-font) (define register-collecting-blit (case-lambda @@ -31,6 +29,16 @@ [(canvas x y w h on off on-x on-y off-x) (register-collecting-blit canvas x y w h on off on-x on-y off-x 0)] [(canvas x y w h on off on-x on-y off-x off-y) (check-instance 'register-collecting-blit canvas% 'canvas% #f canvas) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit x) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit y) + ((check-bounded-integer 0 10000 #f) 'register-collecting-blit w) + ((check-bounded-integer 0 10000 #f) 'register-collecting-blit h) + (check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f on) + (check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f off) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-x) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-y) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-x) + ((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-y) (wx:register-collecting-blit (mred->wx canvas) x y w h on off on-x on-y off-x off-y)])) (define unregister-collecting-blit @@ -38,14 +46,6 @@ (check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas) (wx:unregister-collecting-blit (mred->wx canvas)))) - (define bitmap-dc% - (class100 wx:bitmap-dc% ([bitmap #f]) - (inherit set-bitmap) - (sequence - (super-init) - (when bitmap - (set-bitmap bitmap))))) - (define-syntax check-page-active (syntax-rules () [(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)])) @@ -155,20 +155,6 @@ (super-new))) - (define post-script-dc% - (class (doc+page-check-mixin wx:post-script-dc% 'post-script-dc%) - (init [interactive #t][parent #f][use-paper-bbox #f][as-eps #t]) - - (check-top-level-parent/false '(constructor post-script-dc) parent) - - (define is-eps? (and as-eps #t)) - (define/override (multiple-pages-ok?) (not is-eps?)) - - (as-entry - (lambda () - (let ([p (and parent (mred->wx parent))]) - (as-exit (lambda () (super-make-object interactive p use-paper-bbox as-eps)))))))) - (define printer-dc% (class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f]) (sequence @@ -179,119 +165,14 @@ (as-exit (lambda () (super-init p))))))))) (define get-window-text-extent - (let ([bm #f][dc #f]) - (case-lambda - [(string font) (get-window-text-extent string font #f)] - [(string font combine?) - (check-string 'get-window-text-extent string) - (check-instance 'get-window-text-extent wx:font% 'font% #f font) - (unless bm - (set! bm (make-object wx:bitmap% 2 2)) - (set! dc (make-object wx:bitmap-dc%)) - (send dc set-bitmap bm)) - (unless (send bm ok?) - (error 'get-window-text-extent "couldn't allocate sizing bitmap")) - (let-values ([(w h d a) (send dc get-text-extent string font combine?)]) - (values (inexact->exact w) (inexact->exact h)))]))) - - - (define ugly? - (lambda (a) - (and (positive? (string-length a)) - (not (or (char-alphabetic? (string-ref a 0)) - (char-numeric? (string-ref a 0)) - (char=? #\- (string-ref a 0))))))) - - (define compare-face-names - (lambda (a b) - (let ([a-sp? (char=? #\space (string-ref a 0))] - [b-sp? (char=? #\space (string-ref b 0))] - [a-ugly? (ugly? a)] - [b-ugly? (ugly? b)]) - (cond [(eq? a-sp? b-sp?) - (cond - [(eq? a-ugly? b-ugly?) - (string-locale-ciexact (ceiling w)) (inexact->exact (ceiling h))))])) (define small-delta (case (system-type) [(windows) 0] @@ -301,12 +182,23 @@ [(windows) 1] [else 2])) - (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system)) - (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system)) - (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system)) + (define normal-control-font (make-object wx:font% (wx:get-control-font-size) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) + (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) + (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) (define view-control-font (if (eq? 'macosx (system-type)) - (make-object wx:font% (- (wx:get-control-font-size) 1) 'system) + (make-object wx:font% (- (wx:get-control-font-size) 1) + (wx:get-control-font-face) 'system) normal-control-font)) (define menu-control-font (if (eq? 'macosx (system-type)) - (make-object wx:font% (+ (wx:get-control-font-size) 1) 'system) + (make-object wx:font% (+ (wx:get-control-font-size) 1) + (wx:get-control-font-face) 'system) normal-control-font))) diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 7b5042e6..5680a684 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -1,759 +1,44 @@ +#lang racket/base +(require "wx/platform.rkt" + "wx/common/event.rkt" + "wx/common/timer.rkt" + "wx/common/queue.rkt" + "wx/common/clipboard.rkt" + "wx/common/cursor.rkt" + "wx/common/procs.rkt" + "wx/common/handlers.rkt" + racket/class + racket/draw) -;; The parts of kernel.ss are generated by xctocc. -;; kernel.ss is generated by a target in /mred/wxs/Makefile. +(define (key-symbol-to-integer k) + (error 'key-symbol-to-integer "not yet implemented")) -(module kernel mzscheme - (require (all-except mzlib/class object%)) +(provide (all-from-out "wx/platform.rkt") + clipboard<%> + (all-from-out "wx/common/event.rkt" + "wx/common/timer.rkt" + "wx/common/clipboard.rkt" + "wx/common/cursor.rkt" + "wx/common/procs.rkt") + (all-from-out racket/draw) - ;; Pull pieces out of #%mred-kernel dynamically, so that - ;; the library compiles with setup-plt in mzscheme. - - (define kernel:initialize-primitive-object - (dynamic-require ''#%mred-kernel 'initialize-primitive-object)) - (define kernel:primitive-class-find-method - (dynamic-require ''#%mred-kernel 'primitive-class-find-method)) - (define kernel:primitive-class-prepare-struct-type! - (dynamic-require ''#%mred-kernel 'primitive-class-prepare-struct-type!)) - - (define-syntax define-constant - (lambda (stx) - (syntax-case stx () - [(_ name) - (with-syntax ([kernel:name (datum->syntax-object - (syntax name) - (string->symbol - (format - "kernel:~a" - (syntax-e (syntax name)))) - #f)]) - (syntax - (begin - (define kernel:name (dynamic-require ''#%mred-kernel 'name)) - (provide (protect (rename kernel:name name))))))]))) - - (define-syntax define-function - (lambda (stx) - (syntax-case stx () - [(_ name) - (syntax (define-constant name))]))) - - (define-syntax define-functions - (lambda (stx) - (syntax-case stx () - [(_ name ...) - (syntax (begin (define-function name) ...))]))) - - (define-syntax define-a-class - (let ([defined null]) - (lambda (stx) - (syntax-case stx () - [(_ name print-name super (intf ...) args id ...) - (let ([nm (syntax-e (syntax name))] - [sn (syntax-e (syntax super))] - [ids (map syntax-e (syntax->list (syntax (id ...))))]) - ;; find superclass - (let ([sup (assoc sn defined)]) - (unless (or sup (not sn)) - (raise-syntax-error - 'class - "class not yet defined" - stx - (syntax super))) - ;; add this class to the list: - (set! defined (cons (cons nm (append (if sup - (cdr sup) - null) - ids)) - defined)) - (let-values ([(old new) - (let loop ([l ids][o null][n null]) - (cond - [(null? l) (values o n)] - [(memq (car l) (cdr sup)) - (loop (cdr l) (cons (car l) o) n)] - [else - (loop (cdr l) o (cons (car l) n))]))]) - (with-syntax ([(old ...) (datum->syntax-object #f old #f)] - [(new ...) (datum->syntax-object #f new #f)]) - (syntax - (define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) - (make-primitive-class - (lambda (class prop:object preparer dispatcher prop:unwrap unwrapper more-props) - (kernel:primitive-class-prepare-struct-type! - c prop:object class preparer dispatcher prop:unwrap unwrapper more-props)) - kernel:initialize-primitive-object - 'print-name super (list intf ...) 'args - '(old ...) - '(new ...) - (list - (kernel:primitive-class-find-method c 'old) - ...) - (list - (kernel:primitive-class-find-method c 'new) - ...)))))))))])))) - - (define-syntax define-class - (lambda (stx) - (syntax-case stx () - [(_ name super args id ...) - (syntax - (begin - (define-a-class name name super args id ...) - (provide (protect name))))]))) - - (define-syntax define-private-class - (lambda (stx) - (syntax-case stx () - [(_ name intf super args id ...) - (syntax - (begin - (define-a-class name intf super args id ...) - (define intf (class->interface name)) - (provide (protect intf))))]))) - (define-class object% #f () #f) - (define-class window% object% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - get-handle - is-enabled-to-root? - is-shown-to-root? - set-phantom-size - get-y - get-x - get-width - get-height - popup-menu - center - get-text-extent - get-parent - refresh - screen-to-client - client-to-screen - drag-accept-files - enable - get-position - get-client-size - get-size - fit - is-shown? - show - set-cursor - move - set-size - set-focus - gets-focus? - centre) - (define-class item% window% () #f - set-label - get-label - command) - (define-class message% item% () #f - get-font - set-label - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class bitmap% object% () #f - get-argb-pixels - get-gl-config - set-gl-config - set-loaded-mask - get-loaded-mask - save-file - load-file - is-color? - ok? - get-width - get-height - get-depth) - (define-class button% item% () #f - set-border - set-label - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class choice% item% () #f - set-selection - get-selection - number - clear - append - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-function set-combo-box-font) - (define-class check-box% item% () #f - set-label - set-value - get-value - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class canvas% window% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - get-canvas-background - set-canvas-background - set-background-to-gray - on-scroll - set-scroll-page - set-scroll-range - set-scroll-pos - get-scroll-page - get-scroll-range - get-scroll-pos - scroll - warp-pointer - view-start - set-resize-corner - show-scrollbars - set-scrollbars - get-virtual-size - get-dc - on-char - on-event - on-paint) - (define-private-class dc% dc<%> object% () #f - cache-font-metrics-key - get-alpha - set-alpha - glyph-exists? - end-page - end-doc - start-page - start-doc - ok? - get-gl-context - get-size - get-text-foreground - get-text-background - get-pen - get-font - get-brush - get-text-mode - get-background - get-origin - get-scale - set-origin - set-scale - set-text-mode - try-color - draw-bitmap - draw-bitmap-section - get-char-width - get-char-height - get-text-extent - get-smoothing - set-smoothing - set-text-foreground - set-text-background - set-brush - set-pen - set-font - set-background - get-clipping-region - set-clipping-region - set-clipping-rect - draw-polygon - draw-lines - draw-path - draw-ellipse - draw-arc - draw-text - draw-spline - draw-rounded-rectangle - draw-rectangle - draw-point - draw-line - clear) - (define-function draw-tab) - (define-function draw-tab-base) - (define-class bitmap-dc% dc% () () - get-bitmap - set-bitmap - draw-bitmap-section-smooth - set-argb-pixels - get-argb-pixels - set-pixel - get-pixel) - (define-class post-script-dc% dc% () ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t])) - (define-class printer-dc% dc% () ([parent #f])) - (define-private-class gl-context% gl-context<%> object% () #f - call-as-current - swap-buffers - ok?) - (define-class gl-config% object% () #f - get-double-buffered - set-double-buffered - get-stereo - set-stereo - get-stencil-size - set-stencil-size - get-accum-size - set-accum-size - get-depth-size - set-depth-size - get-multisample-size - set-multisample-size) - (define-class event% object% () ([time-stamp 0]) - get-time-stamp - set-time-stamp) - (define-class control-event% event% () (event-type [time-stamp 0]) - get-event-type - set-event-type) - (define-class popup-event% control-event% () #f - get-menu-id - set-menu-id) - (define-class scroll-event% event% () ([event-type thumb] [direction vertical] [position 0] [time-stamp 0]) - get-event-type - set-event-type - get-direction - set-direction - get-position - set-position) - (define-class key-event% event% () ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f]) - set-other-caps-key-code - get-other-caps-key-code - set-other-shift-altgr-key-code - get-other-shift-altgr-key-code - set-other-altgr-key-code - get-other-altgr-key-code - set-other-shift-key-code - get-other-shift-key-code - get-key-code - set-key-code - get-key-release-code - set-key-release-code - get-shift-down - set-shift-down - get-control-down - set-control-down - get-meta-down - set-meta-down - get-alt-down - set-alt-down - get-caps-down - set-caps-down - get-x - set-x - get-y - set-y) - (define-function key-symbol-to-integer) - (define-class mouse-event% event% () (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f]) - moving? - leaving? - entering? - dragging? - button-up? - button-down? - button-changed? - get-event-type - set-event-type - get-left-down - set-left-down - get-middle-down - set-middle-down - get-right-down - set-right-down - get-shift-down - set-shift-down - get-control-down - set-control-down - get-meta-down - set-meta-down - get-alt-down - set-alt-down - get-caps-down - set-caps-down - get-x - set-x - get-y - set-y) - (define-class frame% window% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - on-toolbar-click - on-menu-click - on-menu-command - on-mdi-activate - enforce-size - on-close - on-activate - designate-root-frame - system-menu - set-modified - create-status-line - is-maximized? - maximize - status-line-exists? - iconized? - set-status-text - get-menu-bar - set-menu-bar - set-icon - iconize - set-title) - (define-class gauge% item% () #f - get-value - set-value - get-range - set-range - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class font% object% () #f - screen-glyph-exists? - get-font-id - get-size-in-pixels - get-underlined - get-smoothing - get-weight - get-point-size - get-style - get-face - get-family) - (define-class font-list% object% () #f - find-or-create-font) - (define-class color% object% () #f - blue - green - red - set - ok? - copy-from) - (define-private-class color-database% color-database<%> object% () #f - find-color) - (define-class point% object% () #f - get-x - set-x - get-y - set-y) - (define-class brush% object% () #f - set-style - get-style - set-stipple - get-stipple - set-color - get-color) - (define-class brush-list% object% () #f - find-or-create-brush) - (define-class pen% object% () #f - set-style - get-style - set-stipple - get-stipple - set-color - get-color - set-join - get-join - set-cap - get-cap - set-width - get-width) - (define-class pen-list% object% () #f - find-or-create-pen) - (define-class cursor% object% () #f - ok?) - (define-class region% object% () (dc) - in-region? - is-empty? - get-bounding-box - xor - subtract - intersect - union - set-path - set-arc - set-polygon - set-ellipse - set-rounded-rectangle - set-rectangle - get-dc) - (define-class dc-path% object% () #f - get-bounding-box - append - reverse - rotate - scale - translate - lines - ellipse - rounded-rectangle - rectangle - curve-to - arc - line-to - move-to - open? - close - reset) - (define-private-class font-name-directory% font-name-directory<%> object% () #f - find-family-default-font-id - find-or-create-font-id - get-family - get-face-name - get-font-id - set-post-script-name - set-screen-name - get-post-script-name - get-screen-name) - (define-function get-control-font-size) - (define-function get-the-font-name-directory) - (define-function get-the-font-list) - (define-function get-the-pen-list) - (define-function get-the-brush-list) - (define-function get-the-color-database) - (define-function cancel-quit) - (define-function fill-private-color) - (define-function flush-display) - (define-function yield) - (define-function write-resource) - (define-function get-resource) - (define-function label->plain-label) - (define-function display-origin) - (define-function display-size) - (define-function bell) - (define-function hide-cursor) - (define-function end-busy-cursor) - (define-function is-busy?) - (define-function begin-busy-cursor) - (define-function get-display-depth) - (define-function is-color-display?) - (define-function file-selector) - (define-class list-box% item% () #f - get-label-font - set-string - set-first-visible-item - set - get-selections - get-first-item - number-of-visible-items - number - get-selection - set-data - get-data - selected? - set-selection - select - delete - clear - append - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class menu% object% () #f - select - get-font - set-width - set-title - set-label - set-help-string - number - enable - check - checked? - append-separator - delete-by-position - delete - append) - (define-class menu-bar% object% () #f - set-label-top - number - enable-top - delete - append) - (define-class menu-item% object% () #f - id) - (define-function id-to-menu-item) - (define-class timer% object% () () - stop - start - notify - interval) - (define-private-class clipboard% clipboard<%> object% () #f - same-clipboard-client? - get-clipboard-bitmap - set-clipboard-bitmap - get-clipboard-data - get-clipboard-string - set-clipboard-string - set-clipboard-client) - (define-function get-the-x-selection) - (define-function get-the-clipboard) - (define-class clipboard-client% object% () () - same-eventspace? - get-types - add-type - get-data - on-replaced) - (define-class ps-setup% object% () () - copy-from - set-margin - set-editor-margin - set-level-2 - set-paper-name - set-translation - set-scaling - set-orientation - set-mode - set-preview-command - set-file - set-command - get-margin - get-editor-margin - get-level-2 - get-paper-name - get-translation - get-scaling - get-orientation - get-mode - get-preview-command - get-file - get-command) - (define-function show-print-setup) - (define-function can-show-print-setup?) - (define-class panel% window% () #f - get-label-position - set-label-position - on-char - on-event - on-paint - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - set-item-cursor - get-item-cursor) - (define-class dialog% window% () #f - system-menu - set-title - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - enforce-size - on-close - on-activate) - (define-class radio-box% item% () #f - button-focus - enable - set-selection - number - get-selection - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class slider% item% () #f - set-value - get-value - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class tab-group% item% () #f - button-focus - set - set-label - delete - append - enable - set-selection - number - get-selection - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - (define-class group-box% item% () #f - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus) - - ;; Functions defined in wxscheme.cxx - (define-functions - special-control-key - special-option-key - application-file-handler - application-quit-handler - application-about-handler - application-pref-handler - get-color-from-user - get-font-from-user - get-face-list - get-panel-background - play-sound - make-eventspace - current-eventspace - event-dispatch-handler - eventspace? - current-ps-setup - queue-callback - middle-queue-key - check-for-break - find-graphical-system-path - get-top-level-windows - register-collecting-blit - unregister-collecting-blit - shortcut-visible-in-label? - eventspace-shutdown? - in-atomic-region - set-menu-tester - location->window - set-dialogs - set-executer - send-event - file-creator-and-type - set-ps-procs - main-eventspace? - eventspace-handler-thread - begin-refresh-sequence - end-refresh-sequence - run-printout - get-double-click-time) - -) -;; end + eventspace? + current-eventspace + queue-event + yield + make-eventspace + event-dispatch-handler + eventspace-shutdown? + main-eventspace? + eventspace-handler-thread + queue-callback + middle-queue-key + get-top-level-windows + begin-busy-cursor + is-busy? + end-busy-cursor + key-symbol-to-integer + application-file-handler + application-quit-handler + application-about-handler + application-pref-handler) diff --git a/collects/mred/private/lock.rkt b/collects/mred/private/lock.rkt index cf5969e9..7d50f669 100644 --- a/collects/mred/private/lock.rkt +++ b/collects/mred/private/lock.rkt @@ -1,131 +1,69 @@ -(module lock mzscheme - (require (prefix wx: "kernel.ss")) - (provide (protect as-entry - as-exit - entry-point - mk-param)) +#lang racket/base +(require (for-syntax racket/base) + ffi/unsafe/atomic) - ;; ;;;;;;;;;;;;; Thread Safety ;;;;;;;;;;;;;;;;;;;; - - ;; When the user creates an object or calls a method, or when the - ;; system invokes a callback, many steps may be required to initialize - ;; or reset fields to maintain invariants. To ensure that other - ;; threads do not call methods during a time when invariants do not - ;; hold, we force all of the following code to be executed in a single - ;; threaded manner, and we temporarily disable breaks. This accompiled - ;; with a single monitor: all entry points into the code use - ;; `entry-point' or `as-entry', and all points with this code that - ;; call back out to user code uses `as-exit'. +(provide (protect-out as-entry ;; alias for call-as-atomic + as-exit ;; alias for call-as-nonatomic + atomically ;; assumes no exceptions! + entry-point ;; converts a proc body to use as-entry + mk-param)) ;; parameter pattern --- out of place here - ;; If an exception is raised within an `enter'ed area, control is - ;; moved back outside by the exception handler, and then the exception - ;; is re-raised. The user can't tell that the exception was caught an - ;; re-raised. But without the catch-and-reraise, the user's exception - ;; handler might try to use GUI elements from a different thread, - ;; leading to deadlock. +;; We need atomic mode for a couple of reasons: +;; +;; * We may need to bracket some (trusted) operations so that the +;; queue thread doesn't poll for events during the operation. +;; The `atomically' form is ok for that if no exceptions will +;; be raised. Otherwise, use the more heavyweight `as-entry'. +;; +;; * The scheme/gui classes have internal-consistency requirements. +;; When the user creates an object or calls a method, or when the +;; system invokes a callback, many steps may be required to +;; initialize or reset fields to maintain invariants. To ensure that +;; other threads do not call methods during a time when invariants +;; do not hold, we force all of the following code to be executed in +;; a single threaded manner, and we temporarily disable breaks. +;; The `as-entry' form or `entry-point' wrapper is normally used for +;; that case. +;; +;; If an exception is raised within an `enter'ed area, control is +;; moved back outside by the exception handler, and then the exception +;; is re-raised. The user can't tell that the exception was caught an +;; re-raised. But without the catch-and-reraise, the user's exception +;; handler might try to use GUI elements from a different thread, or +;; other such things, leading to deadlock. - (define monitor-sema (make-semaphore 1)) - (define monitor-owner #f) +(define as-entry call-as-atomic) - ;; An exception may be constructed while we're entered: - (define entered-err-string-handler - (lambda (s n) - (as-exit - (lambda () - ((error-value->string-handler) s n))))) +(define as-exit call-as-nonatomic) - (define old-paramz #f) - (define old-break-paramz #f) +(define-syntax entry-point + (lambda (stx) + (syntax-case stx (lambda #%plain-lambda case-lambda) + [(_ (lambda args body1 body ...)) + (syntax (lambda args (as-entry (lambda () body1 body ...))))] + [(_ (#%plain-lambda args body1 body ...)) + (syntax (#%plain-lambda args (as-entry (lambda () body1 body ...))))] + [(_ (case-lambda [vars body1 body ...] ...)) + (syntax (case-lambda + [vars (as-entry (lambda () body1 body ...))] + ...))]))) - (define exited-key (gensym 'as-exit)) - (define lock-tag (make-continuation-prompt-tag 'lock)) +(define-syntax-rule (atomically expr ...) + (begin + (start-atomic) + (begin0 (let () expr ...) + (end-atomic)))) - (define (as-entry f) - (cond - [(eq? monitor-owner (current-thread)) - (f)] - [else - (with-continuation-mark - exited-key - #f - (call-with-continuation-prompt - (lambda () - (dynamic-wind - (lambda () - (wx:in-atomic-region monitor-sema) - (set! monitor-owner (current-thread))) - (lambda () - (set! old-paramz (current-parameterization)) - (set! old-break-paramz (current-break-parameterization)) - (parameterize ([error-value->string-handler entered-err-string-handler]) - (parameterize-break - #f - (call-with-exception-handler - (lambda (exn) - ;; Get out of atomic region before letting - ;; an exception handler work - (if (continuation-mark-set-first #f exited-key) - exn ; defer to previous exn handler - (abort-current-continuation - lock-tag - (lambda () (raise exn))))) - f)))) - (lambda () - (set! monitor-owner #f) - (set! old-paramz #f) - (set! old-break-paramz #f) - (semaphore-post monitor-sema) - (wx:in-atomic-region #f)))) - lock-tag - (lambda (t) (t))))])) - - (define (as-exit f) - ;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area")) - (let ([paramz old-paramz] - [break-paramz old-break-paramz]) - (with-continuation-mark - exited-key - #t ; disables special exception handling - (call-with-parameterization - paramz - (lambda () - (call-with-break-parameterization - break-paramz - (lambda () - (dynamic-wind - (lambda () - (set! monitor-owner #f) - (semaphore-post monitor-sema) - (wx:in-atomic-region #f)) - f - (lambda () - (set! old-paramz paramz) - (set! old-break-paramz break-paramz) - (wx:in-atomic-region monitor-sema) - (set! monitor-owner (current-thread))))))))))) - - (define-syntax entry-point - (lambda (stx) - (syntax-case stx (lambda case-lambda) - [(_ (lambda args body1 body ...)) - (syntax (lambda args (as-entry (lambda () body1 body ...))))] - [(_ (case-lambda [vars body1 body ...] ...)) - (syntax (case-lambda - [vars (as-entry (lambda () body1 body ...))] - ...))]))) - - (define-syntax mk-param - (lambda (stx) - (syntax-case stx () - [(_ val filter check force-redraw) - (syntax - (case-lambda - [() val] - [(v) (check v) - (let ([v2 (filter v)]) - (unless (eq? v2 val) - (set! val v2) - (force-redraw)))]))])))) - - - +;; Parameter-method pattern. (Why is this in the "lock" library?) +(define-syntax mk-param + (lambda (stx) + (syntax-case stx () + [(_ val filter check force-redraw) + (syntax + (case-lambda + [() val] + [(v) (check v) + (let ([v2 (filter v)]) + (unless (eq? v2 val) + (set! val v2) + (force-redraw)))]))]))) diff --git a/collects/mred/private/misc.rkt b/collects/mred/private/misc.rkt index 62f71937..4bc03500 100644 --- a/collects/mred/private/misc.rkt +++ b/collects/mred/private/misc.rkt @@ -10,7 +10,8 @@ play-sound timer%) - ;; Currently only used for PS print and preview + ;; Formerly used for PS print and preview: + #; (wx:set-executer (let ([orig-err (current-error-port)]) (lambda (prog . args) @@ -30,7 +31,7 @@ (let loop () (let ([l (read-line p)]) (unless (eof-object? l) - (fprintf orig-err "~a~n" l) + (fprintf orig-err "~a\n" l) (loop))))) (lambda () (close-input-port p))))))]) (echo in) diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index 3f9b1fc5..1ee3068d 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -208,7 +208,7 @@ ((done #t) #f #f))) init-val (list* 'single 'vertical-label style))] [p (make-object horizontal-pane% f)]) - (send p set-alignment 'right 'center) + (send p set-alignment 'right 'center) (send f stretchable-height #f) (ok-cancel (lambda () (make-object button% "OK" p (done #t) '(border))) @@ -284,32 +284,58 @@ (check-top-level-parent/false 'get-color-from-user parent) (check-instance 'get-color-from-user wx:color% 'color% #t color) (check-style 'get-color-from-user #f null style) - (if (not (eq? (system-type) 'unix)) + (if (eq? (wx:color-from-user-platform-mode) 'dialog) (wx:get-color-from-user message (and parent (mred->wx parent)) color) (letrec ([ok? #f] [f (make-object dialog% "Choose Color" parent)] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [canvas (make-object (class canvas% (define/override (on-paint) - (repaint #f #f)) + (repaint void)) (super-new [parent f])))] + [platform-p (and (string? (wx:color-from-user-platform-mode)) + (new horizontal-panel% + [parent f] + [alignment '(right center)]))] [p (make-object vertical-pane% f)] - [repaint (lambda (s e) - (let ([c (make-object wx:color% - (send red get-value) - (send green get-value) - (send blue get-value))]) - (wx:fill-private-color (send canvas get-dc) c)))] - [make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))] + [repaint (lambda (ext) + (let ([c (get-current-color)]) + (ext c) + (wx:fill-private-color (send canvas get-dc) c)))] + [update-and-repaint (lambda (s e) + (repaint + (lambda (c) + (when platform-p + (wx:get-color-from-user c)))))] + [make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))] [red (make-color-slider "Red:")] [green (make-color-slider "Green:")] [blue (make-color-slider "Blue:")] - [bp (make-object horizontal-pane% f)]) - (when color - (send red set-value (send color red)) - (send green set-value (send color green)) - (send blue set-value (send color blue))) - (ok-cancel + [bp (make-object horizontal-pane% f)] + [get-current-color + (lambda () + (make-object wx:color% + (send red get-value) + (send green get-value) + (send blue get-value)))] + [install-color + (lambda (color) + (send red set-value (send color red)) + (send green set-value (send color green)) + (send blue set-value (send color blue)) + (send canvas refresh))]) + (when platform-p + (new button% + [parent platform-p] + [label (wx:color-from-user-platform-mode)] + [callback (lambda (b e) (wx:get-color-from-user 'show))]) + (wx:get-color-from-user (or color + (make-object wx:color% 0 0 0))) + (send (mred->wx f) set-color-callback (lambda () + (install-color + (wx:get-color-from-user 'get))))) + (when color (install-color color)) + (ok-cancel (lambda () (make-object button% "Cancel" bp (done #f))) (lambda () @@ -321,7 +347,4 @@ (send f center) (send f show #t) (and ok? - (make-object wx:color% - (send red get-value) - (send green get-value) - (send blue get-value)))))]))) + (get-current-color))))]))) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index b99d8496..1a3282ab 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -51,6 +51,22 @@ [warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))] [get-dc (entry-point (lambda () (send wx get-dc)))] + [make-bitmap (lambda (w h) + (unless (exact-positive-integer? w) + (raise-type-error (who->name '(method canvas% make-bitmap)) + "exact positive integer" + w)) + (unless (exact-positive-integer? h) + (raise-type-error (who->name '(method canvas% make-bitmap)) + "exact positive integer" + h)) + (send wx make-compatible-bitmap w h))] + + [suspend-flush (lambda () + (send wx begin-refresh-sequence))] + [resume-flush (lambda () + (send wx end-refresh-sequence))] + [flush (lambda () (send wx flush))] [set-canvas-background (entry-point @@ -76,7 +92,7 @@ (sequence (as-entry (lambda () - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches #f parent #f)))))) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches #f parent #f)))))) (define default-paint-cb (lambda (canvas dc) (void))) diff --git a/collects/mred/private/mrcontainer.rkt b/collects/mred/private/mrcontainer.rkt index 44d584c2..c5ff33ee 100644 --- a/collects/mred/private/mrcontainer.rkt +++ b/collects/mred/private/mrcontainer.rkt @@ -42,7 +42,7 @@ [alignment no-val]) (define (make-container% %) ; % implements area<%> - (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan mismatches parent + (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches parent ;; for keyword use [border no-val] [spacing no-val] @@ -122,7 +122,7 @@ (check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c) (send (get-wx-panel) delete-child (mred->wx c))))]) (sequence - (super-init mk-wx get-wx-panel mismatches parent) + (super-init mk-wx get-wx-panel get-wx-outer-pan mismatches parent) (unless (eq? border no-val) (bdr border)) (unless (eq? spacing no-val) (spc spacing)) (unless (eq? alignment no-val) (set-alignment . alignment))))) @@ -131,9 +131,8 @@ (interface (window<%> area-container<%>))) (define (make-area-container-window% %) ; % implements window<%> (and area-container<%>) - (class100* % (area-container-window<%>) (mk-wx get-wx-pan mismatches label parent cursor) - (private-field [get-wx-panel get-wx-pan]) + (class100* % (area-container-window<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor) (sequence - (super-init mk-wx get-wx-panel mismatches label parent cursor))))) + (super-init mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor))))) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 31231d5c..0302d72b 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -11,6 +11,7 @@ "helper.ss" "wx.ss" "wxitem.ss" + "wxlitem.ss" "mrwindow.ss" "mrcontainer.ss") @@ -57,7 +58,7 @@ ;; for keyword use [font no-val]) (rename [super-set-label set-label]) - (private-field [label lbl][callback cb]) + (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)]) (override [get-label (lambda () label)] [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] @@ -68,8 +69,12 @@ (let ([l (if (string? l) (string->immutable-string l) l)]) - (send wx set-label l) - (set! label l))))]) + (when (or (and is-bitmap? + (l . is-a? . wx:bitmap%)) + (and (not is-bitmap?) + (string? l))) + (send wx set-label l) + (set! label l)))))]) (public [hidden-child? (lambda () #f)] ; module-local method [label-checker (lambda () check-label-string/false)] ; module-local method @@ -80,7 +85,7 @@ (sequence (when (string? label) (set! label (string->immutable-string label))) - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches label parent cursor) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches label parent cursor) (unless (hidden-child?) (as-exit (lambda () (send parent after-new-child this))))))) diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index 907e4250..6c42f9ff 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -466,6 +466,4 @@ (define (menu-or-bar-parent who p) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) - (raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p))) - - (wx:set-menu-tester (lambda (m) (is-a? m popup-menu%)))) + (raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index e78fe881..ca4c4d79 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -10,9 +10,7 @@ "kw.ss" "wxpanel.ss" "mrwindow.ss" - "mrcontainer.ss" - "mrtabgroup.ss" - "mrgroupbox.ss") + "mrcontainer.ss") (provide pane% vertical-pane% @@ -29,6 +27,8 @@ container%-keywords area%-keywords) + (define-local-member-name get-initial-label) + (define pane% (class100*/kw (make-subarea% (make-container% area%)) () [(parent) pane%-keywords] @@ -43,13 +43,17 @@ (check-container-parent cwho parent) (as-entry (lambda () - (super-init (lambda () (set! wx (make-object (case who - [(vertical-pane) wx-vertical-pane%] - [(horizontal-pane) wx-horizontal-pane%] - [(grow-box-spacer-pane) wx-grow-box-pane%] - [else wx-pane%]) - this this (mred->wx-container parent) null)) wx) - (lambda () wx) + (super-init (lambda () + (set! wx (make-object (case who + [(vertical-pane) wx-vertical-pane%] + [(horizontal-pane) wx-horizontal-pane%] + [(grow-box-spacer-pane) wx-grow-box-pane%] + [else wx-pane%]) + this this (mred->wx-container parent) null + #f)) + wx) + (lambda () wx) + (lambda () wx) (lambda () (check-container-ready cwho parent)) parent) @@ -70,6 +74,7 @@ (class100*/kw (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) [(parent [style null]) panel%-keywords] (private-field [wx #f]) + (public [get-initial-label (lambda () #f)]) (sequence (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p [(is-a? this tab-panel%) 'tab-panel] @@ -83,10 +88,15 @@ (as-entry (lambda () (super-init (lambda () (set! wx (make-object (case who - [(vertical-panel tab-panel group-box-panel) wx-vertical-panel%] + [(vertical-panel) wx-vertical-panel%] + [(tab-panel) wx-vertical-tab-panel%] + [(group-box-panel) wx-vertical-group-panel%] [(horizontal-panel) wx-horizontal-panel%] [else wx-panel%]) - this this (mred->wx-container parent) style)) wx) + this this (mred->wx-container parent) style + (get-initial-label))) + wx) + (lambda () wx) (lambda () wx) (lambda () (check-container-ready cwho parent)) #f parent #f) @@ -112,6 +122,9 @@ (define tab-panel% (class100*/kw vertical-panel% () [(choices parent [callback (lambda (b e) (void))] [style null] [font no-val]) panel%-keywords] + (private-field [save-choices choices]) + (override [get-initial-label (lambda () save-choices)]) + (sequence (let ([cwho '(constructor tab-panel)]) (unless (and (list? choices) (andmap label-string? choices)) @@ -120,22 +133,12 @@ (check-container-parent cwho parent) (check-style cwho #f '(deleted no-border) style) (check-font cwho font)) - (super-init parent (if (memq 'deleted style) - '(deleted) - null))) - - (private-field - [tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e)) - (if (memq 'no-border style) - null - '(border)) - font)]) - (sequence - (send (mred->wx this) set-first-child-is-hidden)) - - (private-field - [save-choices (map string->immutable-string choices)] - [hidden-tabs? #f]) + (super-init parent (if (memq 'no-border style) + (if (eq? (car style) 'no-border) + (cdr style) + (list (car style))) + (cons 'border style))) + (send (mred->wx this) set-callback callback)) (public [get-number (lambda () (length save-choices))] @@ -144,13 +147,13 @@ (check-label-string '(method tab-panel% append) n) (let ([n (string->immutable-string n)]) (set! save-choices (list-append save-choices (list n))) - (send (mred->wx tabs) append n))))] + (send (mred->wx this) append n))))] [get-selection (lambda () (and (pair? save-choices) - (send (mred->wx tabs) get-selection)))] + (send (mred->wx this) get-selection)))] [set-selection (entry-point (lambda (i) (check-item 'set-selection i) - (send (mred->wx tabs) set-selection i)))] + (send (mred->wx this) set-selection i)))] [delete (entry-point (lambda (i) (check-item 'delete i) @@ -158,7 +161,7 @@ (if (= p i) (cdr l) (cons (car l) (loop (add1 p) (cdr l)))))) - (send (mred->wx tabs) delete i)))] + (send (mred->wx this) delete i)))] [set-item-label (entry-point (lambda (i s) (check-item 'set-item-label i) @@ -168,14 +171,14 @@ (if (zero? i) (cons s (cdr save-choices)) (cons (car save-choices) (loop (cdr save-choices) (sub1 i)))))) - (send (mred->wx tabs) set-label i s))))] + (send (mred->wx this) set-label i s))))] [set (entry-point (lambda (l) (unless (and (list? l) (andmap label-string? l)) (raise-type-error (who->name '(method tab-panel% set)) "list of strings (up to 200 characters)" l)) (set! save-choices (map string->immutable-string l)) - (send (mred->wx tabs) set l)))] + (send (mred->wx this) set l)))] [get-item-label (entry-point (lambda (i) (check-item 'get-item-label i) @@ -194,10 +197,13 @@ m (sub1 m))) n))))]))) - (define group-box-panel% (class100*/kw vertical-panel% () [(label parent [style null] [font no-val]) panel%-keywords] + (private-field + [lbl label]) + (override [get-initial-label (lambda () lbl)]) + (sequence (let ([cwho '(constructor group-box-panel)]) (check-label-string cwho label) @@ -211,14 +217,8 @@ (when (eq? vert-margin no-val) (set! vert-margin 2)) (super-init parent (if (memq 'deleted style) - '(deleted) - null))) - - (private-field - [gbox (make-object group-box% label this null font)] - [lbl label]) - (sequence - (send (mred->wx this) set-first-child-is-hidden)) + '(deleted) + null))) (override [set-label (entry-point @@ -227,5 +227,5 @@ (set! lbl (if (immutable? s) s (string->immutable-string s))) - (send gbox set-label s)))] + (send (mred->wx this) set-label s)))] [get-label (lambda () lbl)])))) diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index 179b9b46..f7d81de5 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -57,11 +57,16 @@ (private-field [wx #f]) (public + [set-field-background (lambda (c) + (check-instance '(method text-field% set-field-color) + wx:color% 'color% #f c) + (send wx set-field-background c))] + [get-field-background (lambda () (send wx get-field-background))] [get-editor (entry-point (lambda () (send wx get-editor)))] [get-value (lambda () (send wx get-value))] ; note: wx method doesn't expect as-entry [set-value (entry-point (lambda (v) - (check-string '(method text-control<%> set-value) v) + (check-string '(method text-field% set-value) v) (send wx set-value v)))]) (sequence ;; Technically a bad way to change margin defaults, since it's @@ -96,36 +101,47 @@ parent callback init-value style #f font)) + (private + [prep-popup + (lambda () + (send menu on-demand) + (let ([items (send menu get-items)] + [wx (mred->wx this)]) + (send wx clear-combo-items) + (for-each + (lambda (item) + (unless (item . is-a? . separator-menu-item%) + (send wx append-combo-item + (send item get-plain-label) + (lambda () + (send item command + (make-object wx:control-event% 'menu-popdown)))))) + items)))]) (public - [on-popup (lambda (e) - (let-values ([(w h) (get-size)] - [(cw) (send (mred->wx this) get-canvas-width)]) - (send menu set-min-width cw) - (popup-menu menu (- w cw) h)))] + [on-popup (lambda (e) (void))] [get-menu (lambda () menu)] [append (lambda (item) (check-label-string '(method combo-field% append) item) - (make-object menu-item% item menu - (lambda (i e) - (focus) - (set-value item) - (let ([e (get-editor)]) - (send e set-position 0 (send e last-position))) - (send (as-entry (lambda () (mred->wx this))) - command - (make-object wx:control-event% 'text-field)))))]) - (override - [on-subwindow-event (lambda (w e) - (and (send e button-down?) - (let-values ([(cw) (send (mred->wx this) get-canvas-width)]) - (and ((send e get-x) . >= . (- cw side-combo-width)) - (begin - (on-popup e) - #t)))))]) + (make-object menu-item% item menu + (lambda (i e) + (handle-selected item))))]) + (private + [handle-selected (lambda (item) + (focus) + (set-value item) + (let ([e (get-editor)]) + (send e set-position 0 (send e last-position))) + (send (as-entry (lambda () (mred->wx this))) + command + (make-object wx:control-event% 'text-field)))]) (private-field [menu (new popup-menu% [font font])]) (sequence - (for-each (lambda (item) - (append item)) - choices) - (super-init label parent callback init-value (list* combo-flag 'single style)))))) + (super-init label parent callback init-value (list* combo-flag 'single style)) + (send (mred->wx this) + set-on-popup + (lambda () + (on-popup (make-object wx:control-event% 'menu-popdown)) + (prep-popup))) + (for-each (lambda (item) (append item)) + choices))))) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index ef591530..a290834d 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -12,6 +12,7 @@ "wx.ss" "wxtop.ss" "wxpanel.ss" + "wxitem.ss" "mrwindow.ss" "mrcontainer.ss") @@ -41,6 +42,10 @@ (define-keywords top-level-window%-keywords window%-keywords container%-keywords area%-keywords) + (define-local-member-name + do-create-status-line + do-set-status-text) + (define basic-top-level-window% (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (mk-wx mismatches label parent) @@ -93,7 +98,7 @@ (lambda (w h) (check-range-integer '(method top-level-window<%> resize) w) (check-range-integer '(method top-level-window<%> resize) h) - (send wx set-size -1 -1 w h)))] + (send wx set-size -11111 -11111 w h)))] [get-focus-window (entry-point (lambda () (let ([w (send wx get-focus-window)]) @@ -111,24 +116,41 @@ [on-message (lambda (m) (void))]) (private-field [wx #f] + [mid-panel #f] ;; supports status line [wx-panel #f] + [status-message #f] [finish (entry-point (lambda (top-level hide-panel?) - (set! wx-panel (make-object wx-vertical-panel% #f this top-level null)) + (set! mid-panel (make-object wx-vertical-panel% #f this top-level null #f)) + (send mid-panel skip-subwindow-events? #t) + (send (send mid-panel area-parent) add-child mid-panel) + (set! wx-panel (make-object wx-vertical-panel% #f this mid-panel null #f)) + (send wx-panel skip-subwindow-events? #t) (send (send wx-panel area-parent) add-child wx-panel) (send top-level set-container wx-panel) (when hide-panel? - (send wx-panel show #f)) + (send mid-panel show #f)) top-level))]) + (public + [do-create-status-line (lambda () + (unless status-message + (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) + (send status-message stretchable-in-x #t)))] + [do-set-status-text (lambda (s) + (when status-message + (send status-message set-label s)))]) (sequence - (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor)))) + (super-init (lambda () (set! wx (mk-wx finish)) wx) + (lambda () wx-panel) (lambda () mid-panel) + mismatches label parent arrow-cursor)))) (define frame% (class100*/kw basic-top-level-window% () [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) top-level-window%-keywords] - (inherit on-traverse-char on-system-menu-char) + (inherit on-traverse-char on-system-menu-char + do-create-status-line do-set-status-text) (sequence (let ([cwho '(constructor frame)]) (check-label-string cwho label) @@ -164,8 +186,8 @@ (send wx handle-menu-key e)))] [on-mdi-activate (lambda (on?) (void))] [on-toolbar-button-click (lambda () (void))] - [create-status-line (entry-point (lambda () (unless status-line? (send wx create-status-line) (set! status-line? #t))))] - [set-status-text (lambda (s) (send wx set-status-text s))] + [create-status-line (entry-point (lambda () (unless status-line? (do-create-status-line) (set! status-line? #t))))] + [set-status-text (lambda (s) (do-set-status-text s))] [has-status-line? (lambda () status-line?)] [iconize (entry-point (lambda (on?) (send wx iconize on?)))] [is-iconized? (entry-point (lambda () (send wx iconized?)))] @@ -215,7 +237,7 @@ (check-label-string cwho label) (check-top-level-parent/false cwho parent) (for-each (lambda (x) (check-dimension cwho x)) (list width height x y)) - (check-style cwho #f '(no-caption resize-border no-sheet) style))) + (check-style cwho #f '(no-caption resize-border no-sheet close-button) style))) (rename [super-on-subwindow-char on-subwindow-char]) (private-field [wx #f]) (override @@ -228,7 +250,7 @@ (lambda () (super-init (lambda (finish) (set! wx (finish (make-object wx-dialog% this this - (and parent (mred->wx parent)) label #t + (and parent (mred->wx parent)) label (or x -11111) (or y -11111) (or width 0) (or height 0) style) #f)) diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index 6572640e..2a4c4a1b 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -21,7 +21,9 @@ window<%> (protect window%-keywords) subwindow<%> - (protect make-window%)) + (protect make-window%) + + (protect set-get-outer-panel)) (define area<%> (interface () @@ -36,8 +38,11 @@ [stretchable-width no-val] [stretchable-height no-val]) + (define-local-member-name + set-get-outer-panel) + (define area% - (class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt + (class100* mred% (area<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches prnt ;; for keyword use: [min-width no-val] [min-height no-val] @@ -49,15 +54,15 @@ (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height))) (mismatches)) (private-field - [get-wx-panel get-wx-pan] + [get-wx-outer-panel get-outer-wx-pan] [parent prnt]) (public [get-parent (lambda () parent)] [get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))] - [(minw min-width) (param get-wx-panel min-width)] - [(minh min-height) (param get-wx-panel min-height)] - [(sw stretchable-width) (param get-wx-panel stretchable-in-x)] - [(sh stretchable-height) (param get-wx-panel stretchable-in-y)] + [(minw min-width) (param get-wx-outer-panel min-width)] + [(minh min-height) (param get-wx-outer-panel min-height)] + [(sw stretchable-width) (param get-wx-outer-panel stretchable-in-x)] + [(sh stretchable-height) (param get-wx-outer-panel stretchable-in-y)] [get-graphical-min-size (entry-point (lambda () (if (wx . is-a? . wx-basic-panel<%>) (apply values (send wx get-graphical-min-size)) @@ -82,7 +87,7 @@ [vert-margin no-val]) (define (make-subarea% %) ; % implements area<%> - (class100* % (subarea<%>) (mk-wx get-wx-pan mismatches parent + (class100* % (subarea<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches parent ;; for keyword use [horiz-margin no-val] [vert-margin no-val]) @@ -95,7 +100,7 @@ [(hm horiz-margin) (param get-wx-panel x-margin)] [(vm vert-margin) (param get-wx-panel y-margin)]) (sequence - (super-init mk-wx get-wx-panel mismatches parent) + (super-init mk-wx get-wx-panel get-outer-wx-pan mismatches parent) (unless (eq? horiz-margin no-val) (hm horiz-margin)) (unless (eq? vert-margin no-val) (vm vert-margin))))) @@ -119,7 +124,7 @@ (interface (window<%> subarea<%>))) (define (make-window% top? %) ; % implements area<%> - (class100* % (window<%>) (mk-wx get-wx-panel mismatches lbl parent crsr + (class100* % (window<%>) (mk-wx get-wx-panel get-outer-wx-panel mismatches lbl parent crsr ;; for keyword use [enabled #t]) (private-field [label lbl][cursor crsr]) @@ -228,5 +233,5 @@ (private-field [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel mismatches parent) + (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent) (unless enabled (enable #f)))))) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index bd8ba41f..9da20e4c 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -1,11 +1,10 @@ -(module snipfile mzscheme - (require mzlib/class - mzlib/etc - mzlib/port +(module snipfile racket/base + (require racket/class + racket/port syntax/moddep - (prefix wx: "kernel.ss") - (prefix wx: "wxme/snip.ss") - (prefix wx: "wxme/cycle.ss") + (prefix-in wx: "kernel.ss") + (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: "wxme/cycle.ss") "check.ss" "editor.ss") @@ -72,7 +71,8 @@ ;; starting at position `start-in' ;; and ending at position `end'. (define open-input-text-editor - (opt-lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f]) + (lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f] + #:lock-while-reading? [lock-while-reading? #f]) ;; Check arguments: (unless (text . is-a? . text%) (raise-type-error 'open-input-text-editor "text% object" text)) @@ -105,24 +105,33 @@ ;; It's all text, and it's short enough: just read it into a string (open-input-string (send text get-text start end) port-name) ;; It's all text, so the reading process is simple: - (let ([start start]) - (let-values ([(pipe-r pipe-w) (make-pipe)]) + (let ([start start]) + (when lock-while-reading? (send text lock #t)) + (let-values ([(pipe-r pipe-w) (make-pipe)]) (make-input-port/read-to-peek - port-name + port-name (lambda (s) (let ([v (read-bytes-avail!* s pipe-r)]) (if (eq? v 0) (let ([n (min 4096 (- end start))]) (if (zero? n) (begin - (close-output-port pipe-w) - eof) + (close-output-port pipe-w) + (when lock-while-reading? + (set! lock-while-reading? #f) + (send text lock #f)) + eof) (begin (write-string (send text get-text start (+ start n)) pipe-w) (set! start (+ start n)) - (read-bytes-avail!* s pipe-r)))) + (let ([ans (read-bytes-avail!* s pipe-r)]) + (when lock-while-reading? + (when (eof-object? ans) + (set! lock-while-reading? #f) + (send text lock #f))) + ans)))) v))) - (lambda (s skip general-peek) + (lambda (s skip general-peek) (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) (if (eq? v 0) (general-peek s skip) @@ -184,17 +193,21 @@ [port (make-input-port/read-to-peek port-name (lambda (s) - (let ([v (read-bytes-avail!* s pipe-r)]) - (if (eq? v 0) - (read-chars s) - v))) - (lambda (s skip general-peek) + (let* ([v (read-bytes-avail!* s pipe-r)] + [res (if (eq? v 0) (read-chars s) v)]) + (when (eof-object? res) + (when lock-while-reading? + (set! lock-while-reading? #f) + (send text lock #f))) + res)) + (lambda (s skip general-peek) (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) (if (eq? v 0) (general-peek s skip) v))) close)]) - (if (is-a? snip wx:string-snip%) + (when lock-while-reading? (send text lock #t)) + (if (is-a? snip wx:string-snip%) ;; Special handling for initial snip string in ;; case it starts too early: (let* ([snip-start (gsp snip)] @@ -235,7 +248,7 @@ (apply values last-time-values) (call-with-values (lambda () (call-with-continuation-prompt (lambda () (eval - (datum->syntax-object + (datum->syntax #f (cons '#%top-interaction exp) exp))) @@ -271,7 +284,7 @@ p)) (define open-output-text-editor - (opt-lambda (text [start 'end] [special-filter values] [port-name text]) + (lambda (text [start 'end] [special-filter values] [port-name text]) (define pos (if (eq? start 'end) (send text last-position) (min start diff --git a/collects/mred/private/syntax.rkt b/collects/mred/private/syntax.rkt index 21b0b231..431e1a26 100644 --- a/collects/mred/private/syntax.rkt +++ b/collects/mred/private/syntax.rkt @@ -1,275 +1,3 @@ #lang scheme/base -(require scheme/class - scheme/stxparam - (for-syntax scheme/base)) - -(provide defclass defclass* - def/public def/public-final def/override def/override-final define/top case-args - maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts - make-literal symbol-in make-procedure - method-name init-name - let-boxes - properties field-properties init-properties - ->long - assert) - -(define-syntax-parameter class-name #f) - -(define-syntax-rule (defclass name super . body) - (defclass* name super () . body)) -(define-syntax-rule (defclass* name super intfs . body) - (define name - (syntax-parameterize ([class-name 'name]) - (class* super intfs . body)))) - -(define-syntax (def/public stx) - #`(def/thing define/public #,stx)) -(define-syntax (def/public-final stx) - #`(def/thing define/public-final #,stx)) -(define-syntax (def/override stx) - #`(def/thing define/override #,stx)) -(define-syntax (def/override-final stx) - #`(def/thing define/override-final #,stx)) -(define-syntax (define/top stx) - #`(def/thing define #,stx)) - -(define (method-name class method) - (string->symbol (format "~a in ~a" method class))) -(define (init-name class) - (string->symbol (format "initialization for ~a" class))) - -(define-syntax just-id - (syntax-rules () - [(_ [id default]) id] - [(_ id) id])) - -(define-struct named-pred (pred make-name) - #:property prop:procedure (struct-field-index pred)) - -(define (apply-pred pred val) - (cond - [(procedure? pred) (pred val)] - [(class? pred) (val . is-a? . pred)] - [(interface? pred) (val . is-a? . pred)] - [else (error 'check-arg "unknown predicate type: ~e" pred)])) - -(define (make-or-false pred) - (make-named-pred (lambda (v) - (or (not v) (apply-pred pred v))) - (lambda () - (string-append (predicate-name pred) - " or #f")))) - -(define (make-box pred) - (make-named-pred (lambda (v) - (and (box? v) (apply-pred pred (unbox v)))) - (lambda () - (string-append "boxed " (predicate-name pred))))) - -(define (make-list pred) - (make-named-pred (lambda (v) - (and (list? v) (andmap (lambda (v) (apply-pred pred v)) v))) - (lambda () - (string-append "list of " (predicate-name pred))))) - -(define (make-alts a b) - (make-named-pred (lambda (v) - (or (apply-pred a v) (apply-pred b v))) - (lambda () - (string-append (predicate-name a) - " or " - (predicate-name b))))) - -(define (make-literal lit) - (make-named-pred (lambda (v) (equal? v lit)) - (lambda () (if (symbol? lit) - (format "'~s" lit) - (format "~s" lit))))) - -(define (make-symbol syms) - (make-named-pred (lambda (v) (memq v syms)) - (lambda () - (let loop ([syms syms]) - (cond - [(null? (cdr syms)) - (format "'~s" (car syms))] - [(null? (cddr syms)) - (format "'~s, or '~s" (car syms) (cadr syms))] - [else - (format "'~s, ~a" (car syms) (loop (cdr syms)))]))))) -(define-syntax-rule (symbol-in sym ...) - (make-symbol '(sym ...))) - -(define (make-procedure arity) - (make-named-pred (lambda (p) - (and (procedure? p) - (procedure-arity-includes? p arity))) - (lambda () - (format "procedure (arity ~a)" arity)))) - -(define (check-arg val pred pos) - (if (apply-pred pred val) - #f - (cons (predicate-name pred) - pos))) - -(define (predicate-name pred) - (cond - [(named-pred? pred) ((named-pred-make-name pred))] - [(procedure? pred) (let ([s (symbol->string (object-name pred))]) - (substring s 0 (sub1 (string-length s))))] - [(or (class? pred) (interface? pred)) - (format "~a instance" (object-name pred))] - [else "???"])) - -(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v))) - (lambda () "box or #f"))) -(define (any? v) #t) -(define (bool? v) #t) -(define (nonnegative-real? v) (and (real? v) (v . >= . 0))) - -(define (method-of cls nam) - (if cls - (string->symbol (format "~a method of ~a" nam cls)) - nam)) - -(define-syntax (def/thing stx) - (syntax-case stx () - [(_ define/orig (_ (id [arg-type arg] ...))) - (raise-syntax-error #f "missing body" stx)] - [(_ define/orig (_ (id [arg-type arg] ...) . body)) - (with-syntax ([(_ _ orig-stx) stx] - [(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))]) - i)] - [cname (syntax-parameter-value #'class-name)]) - (syntax/loc #'orig-stx - (define/orig (id arg ...) - (let ([bad (or (check-arg (just-id arg) arg-type pos) - ...)]) - (when bad - (raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...))) - (let () - . body))))])) - -(define-for-syntax lifted (make-hash)) -(define-syntax (lift-predicate stx) - (syntax-case stx () - [(_ id) (identifier? #'id) #'id] - [(_ expr) - (let ([d (syntax->datum #'expr)]) - (or (hash-ref lifted d #f) - (let ([id (syntax-local-lift-expression #'expr)]) - (hash-set! lifted d id) - id)))])) - -(define-syntax (case-args stx) - (syntax-case stx () - [(_ expr [([arg-type arg] ...) rhs ...] ... who) - (with-syntax ([((min-args-len . max-args-len) ...) - (map (lambda (args) - (let ([args (syntax->list args)]) - (cons (let loop ([args args]) - (if (or (null? args) - (not (identifier? (car args)))) - 0 - (add1 (loop (cdr args))))) - (length args)))) - (syntax->list #'((arg ...) ...)))]) - #'(let* ([args expr] - [len (length args)]) - (find-match - (lambda (next) - (if (and (len . >= . min-args-len) - (len . <= . max-args-len)) - (apply - (lambda (arg ...) - (if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...) - (lambda () rhs ...) - next)) - args) - next)) - ... - (lambda (next) - (bad-args who args)))))])) - -(define (bad-args who args) - (error who "bad argument combination:~a" - (apply string-append (map (lambda (x) (format " ~e" x)) - args)))) - -(define-syntax find-match - (syntax-rules () - [(_ proc) - ((proc #f))] - [(_ proc1 proc ...) - ((proc1 (lambda () (find-match proc ...))))])) - -(define-syntax-rule (let-boxes ([id init] ...) - call - body ...) - (let ([id (box init)] ...) - call - (let ([id (unbox id)] ...) - body ...))) - -(define-syntax (do-properties stx) - (syntax-case stx () - [(_ define-base check-immutable [[type id] expr] ...) - (let ([ids (syntax->list #'(id ...))]) - (with-syntax ([(getter ...) - (map (lambda (id) - (datum->syntax id - (string->symbol - (format "get-~a" (syntax-e id))) - id)) - ids)] - [(setter ...) - (map (lambda (id) - (datum->syntax id - (string->symbol - (format "set-~a" (syntax-e id))) - id)) - ids)]) - #'(begin - (define-base id expr) ... - (define/public (getter) id) ... - (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))])) - -(define-syntax coerce - (syntax-rules (bool?) - [(_ bool? v) (and v #t)] - [(_ _ v) v])) - -(define-syntax properties - (syntax-rules () - [(_ #:check-immutable check-immutable . props) - (do-properties define check-immutable . props)] - [(_ . props) - (do-properties define void . props)])) -(define-syntax field-properties - (syntax-rules () - [(_ #:check-immutable check-immutable . props) - (do-properties define-field check-immutable . props)] - [(_ . props) - (do-properties define-field void . props)])) -(define-syntax-rule (define-field id val) (field [id val])) -(define-syntax init-properties - (syntax-rules () - [(_ #:check-immutable check-immutable . props) - (do-properties define-init check-immutable . props)] - [(_ . props) - (do-properties define-init void . props)])) -(define-syntax-rule (define-init id val) (begin - (init [(internal id) val]) - (define id internal))) - -(define (->long i) - (cond - [(eqv? -inf.0 i) (- (expt 2 64))] - [(eqv? +inf.0 i) (expt 2 64)] - [(eqv? +nan.0 i) 0] - [else (inexact->exact (floor i))])) - - -(define-syntax-rule (assert e) (void)) -; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e))) +(require racket/draw/private/syntax) +(provide (all-from-out racket/draw/private/syntax)) diff --git a/collects/mred/private/te.rkt b/collects/mred/private/te.rkt new file mode 100644 index 00000000..884c4cc1 --- /dev/null +++ b/collects/mred/private/te.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require racket/class + racket/draw) + +(provide get-window-text-extent*) + +(define get-window-text-extent* + (let ([bm #f][dc #f]) + (case-lambda + [(string font) (get-window-text-extent* string font #f)] + [(string font combine?) + (unless bm + (set! bm (make-object bitmap% 2 2)) + (set! dc (make-object bitmap-dc%)) + (send dc set-bitmap bm)) + (unless (send bm ok?) + (error 'get-window-text-extent "couldn't allocate sizing bitmap")) + (let-values ([(w h d a) (send dc get-text-extent string font combine?)]) + (values w h d a))]))) diff --git a/collects/mred/private/wx/cocoa/README.txt b/collects/mred/private/wx/cocoa/README.txt new file mode 100644 index 00000000..df66a5c0 --- /dev/null +++ b/collects/mred/private/wx/cocoa/README.txt @@ -0,0 +1,16 @@ + +Allocation rules: + + * Use `as-objc-allocation' when creating a Cocoa object. When the + resulting reference becomes unreachable, the Cocoa object will be + released. + + * Use `with-autorelease' in atomic mode around calls that autorelease + and where the release should take effect immediate. Do not create + an autorelease pool except in atomic mode. + + * Other autoreleased objects may end up in the root pool installed by + "pool.rkt". The root pool is periodically destroyed and replaced; + call `queue-autorelease-flush' if you need to encurage replacement + of the pool. If you need to use an object htat might be autoflushed, + be sure that you're in atomic mode. diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt new file mode 100644 index 00000000..1987e278 --- /dev/null +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -0,0 +1,162 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "window.rkt" + "../common/event.rkt" + "image.rkt") + +(provide + (protect-out button% + core-button% + MyButton)) + +;; ---------------------------------------- + +(import-class NSButton NSView NSImageView) + +(define MIN-BUTTON-WIDTH 72) +(define BUTTON-EXTRA-WIDTH 12) + +(define NSSmallControlSize 1) +(define NSMiniControlSize 2) + +(define-objc-class MyButton NSButton + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (clicked: [_id sender]) + (queue-window*-event wxb (lambda (wx) (send wx clicked))))) + +(defclass core-button% item% + (init parent cb label x y w h style font + [button-type #f]) + (init-field [event-type 'button]) + (inherit get-cocoa get-cocoa-window init-font + register-as-child) + + (define button-cocoa + (let ([cocoa + (as-objc-allocation + (tell (tell MyButton alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize w h))))]) + (when button-type + (tellv cocoa setButtonType: #:type _int button-type)) + (unless button-type + (tellv cocoa setBezelStyle: #:type _int (if (not (string? label)) + NSRegularSquareBezelStyle + NSRoundedBezelStyle))) + (cond + [(string? label) + (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] + [(send label ok?) + (if button-type + (tellv cocoa setTitle: #:type _NSString "") + (tellv cocoa setImage: (bitmap->image label)))] + [else + (tellv cocoa setTitle: #:type _NSString "")]) + (init-font cocoa font) + (tellv cocoa sizeToFit) + (when (and (eq? event-type 'button) + (string? label)) + (when font + (let ([n (send font get-point-size)]) + ;; If the font is small, adjust the control size: + (when (n . < . sys-font-size) + (tellv (tell cocoa cell) + setControlSize: #:type _int + (if (n . < . (- sys-font-size 2)) + NSMiniControlSize + NSSmallControlSize)) + (tellv cocoa sizeToFit)) + ;; If the font is big, use a scalable control shape: + (when (n . > . (+ sys-font-size 2)) + (tellv cocoa setBezelStyle: #:type _int NSRegularSquareBezelStyle) + (tellv cocoa sizeToFit)))) + (let ([frame (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize (+ BUTTON-EXTRA-WIDTH + (max MIN-BUTTON-WIDTH + (NSSize-width (NSRect-size frame)))) + (NSSize-height (NSRect-size frame))))))) + cocoa)) + + (define-values (cocoa image-cocoa) + (if (and button-type + (not (string? label)) + (send label ok?)) + ;; Check-box image: need an view to join a button and an image view: + ;; (Could we use the NSImageButtonCell from the radio-box implementation + ;; instead?) + (let* ([frame (tell #:type _NSRect button-cocoa frame)] + [new-width (+ (NSSize-width (NSRect-size frame)) + (send label get-width))] + [new-height (max (NSSize-height (NSRect-size frame)) + (send label get-height))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height))))] + [image-cocoa (as-objc-allocation + (tell (tell NSImageView alloc) init))]) + (tellv cocoa addSubview: button-cocoa) + (tellv cocoa addSubview: image-cocoa) + (tellv image-cocoa setImage: (bitmap->image label)) + (tellv image-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) + (quotient (- new-height + (send label get-height)) + 2)) + (make-NSSize (send label get-width) + (send label get-height)))) + (tellv button-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (make-NSSize new-width new-height))) + (set-ivar! button-cocoa wxb (->wxb this)) + (values cocoa image-cocoa))) + (values button-cocoa #f))) + + (define we (make-will-executor)) + + (super-new [parent parent] + [cocoa cocoa] + [no-show? (memq 'deleted style)] + [callback cb]) + + (when (memq 'border style) + (tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell))) + + (tellv button-cocoa setTarget: button-cocoa) + (tellv button-cocoa setAction: #:type _SEL (selector clicked:)) + + (define/override (get-cocoa-control) button-cocoa) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (set-label label) + (cond + [(string? label) + (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] + [else + (tellv (or image-cocoa cocoa) setImage: (bitmap->image label))])) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type event-type] + [time-stamp (current-milliseconds)]))) + + (def/public-unimplemented set-border)) + +(define button% + (class core-button% (super-new))) + diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt new file mode 100644 index 00000000..7e3d0cdb --- /dev/null +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -0,0 +1,835 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + racket/draw + racket/draw/private/gl-context + racket/draw/private/color + "pool.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "dc.rkt" + "bitmap.rkt" + "cg.rkt" + "queue.rkt" + "item.rkt" + "gc.rkt" + "image.rkt" + "../common/backing-dc.rkt" + "../common/canvas-mixin.rkt" + "../common/event.rkt" + "../common/queue.rkt" + "../../syntax.rkt" + "../../lock.rkt" + "../common/freeze.rkt") + +(provide + (protect-out canvas%)) + +;; ---------------------------------------- + +(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow + NSImageView NSTextFieldCell + NSOpenGLView NSOpenGLPixelFormat) + +(import-protocol NSComboBoxDelegate) + +(define NSWindowAbove 1) + +(define o (current-error-port)) + +;; Called when a canvas has no backing store ready +(define (clear-background wxb) + (let ([wx (->wx wxb)]) + (when wx + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState))))))) + +(define-objc-mixin (MyViewMixin Superclass) + #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) + [wxb] + (-a _void (drawRect: [_NSRect r]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (unless (send wx paint-or-queue-paint) + (clear-background wxb) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)))))) + (-a _void (viewWillMoveToWindow: [_id w]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () (send wx fix-dc))))))) + (-a _void (onHScroll: [_id scroller]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx (send wx do-scroll 'horizontal scroller))))) + (-a _void (onVScroll: [_id scroller]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx (send wx do-scroll 'vertical scroller)))))) + +(define-objc-class MyView NSView + #:mixins (MyViewMixin) + [wxb]) + +(define-objc-class MyGLView NSOpenGLView + #:mixins (MyViewMixin) + [wxb]) + +(define-objc-class FrameView NSView + [] + (-a _void (drawRect: [_NSRect r]) + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [r (tell #:type _NSRect self bounds)]) + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (CGContextAddRect cg r) + (CGContextStrokePath cg)) + (tellv ctx restoreGraphicsState)))) + +(define-objc-class CornerlessFrameView NSView + [] + (-a _void (drawRect: [_NSRect r]) + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [r (tell #:type _NSRect self bounds)]) + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (let* ([l (NSPoint-x (NSRect-origin r))] + [t (NSPoint-y (NSRect-origin r))] + [b (+ t (NSSize-height (NSRect-size r)))] + [r (+ l (NSSize-width (NSRect-size r)))]) + (CGContextAddLines cg + (vector + (make-NSPoint r (+ t scroll-width)) + (make-NSPoint r b) + (make-NSPoint l b) + (make-NSPoint l t) + (make-NSPoint (- r scroll-width) t)))) + (CGContextStrokePath cg)) + (tellv ctx restoreGraphicsState)))) + +(define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) +(define-cocoa NSRectFill (_fun _NSRect -> _void)) + +(define bezel-cell + (tell (tell NSTextFieldCell alloc) initTextCell: #:type _NSString "")) +(tellv bezel-cell setBezeled: #:type _BOOL #t) + +(define-objc-class FocusView NSView + [on?] + (-a _void (setFocusState: [_BOOL is-on?]) + (set! on? is-on?)) + (-a _void (drawRect: [_NSRect r]) + (let ([f (tell #:type _NSRect self frame)]) + (tellv bezel-cell + drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2) + (let ([s (NSRect-size r)]) + (make-NSSize (- (NSSize-width s) 4) + (- (NSSize-height s) 4)))) + inView: self)) + (when on? + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (NSSetFocusRingStyle 0) + (let ([r (tell #:type _NSRect self bounds)]) + (NSRectFill (make-NSRect (make-NSPoint + (+ (NSPoint-x (NSRect-origin r)) 2) + (+ (NSPoint-y (NSRect-origin r)) 2)) + (make-NSSize + (- (NSSize-width (NSRect-size r)) 4) + (- (NSSize-height (NSRect-size r)) 4))))) + (tellv ctx restoreGraphicsState))))) + +(define-objc-class MyComboBox NSComboBox + #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) + #:protocols (NSComboBoxDelegate) + [wxb] + (-a _void (drawRect: [_NSRect r]) + (super-tell #:type _void drawRect: #:type _NSRect r) + (let ([wx (->wx wxb)]) + (when wx + (unless (send wx paint-or-queue-paint) + (unless (send wx during-menu-click?) + (clear-background wxb) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)))))) + (-a _void (comboBoxWillPopUp: [_id notification]) + (let ([wx (->wx wxb)]) + (when wx + (send wx starting-combo)))) + (-a _void (comboBoxWillDismiss: [_id notification]) + (let ([wx (->wx wxb)]) + (when wx + (send wx ending-combo)))) + (-a _void (viewWillMoveToWindow: [_id w]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () (send wx fix-dc)))))))) + +(define NSOpenGLPFADoubleBuffer 5) +(define NSOpenGLPFAStereo 6) +(define NSOpenGLPFAColorSize 8) +(define NSOpenGLPFAAlphaSize 11) +(define NSOpenGLPFADepthSize 12) +(define NSOpenGLPFAStencilSize 13) +(define NSOpenGLPFAAccumSize 14) +(define NSOpenGLPFAOffScreen 53) +(define NSOpenGLPFASampleBuffers 55) +(define NSOpenGLPFASamples 56) +(define NSOpenGLPFAMultisample 59) + +(define (gl-config->pixel-format conf) + (let ([conf (or conf (new gl-config%))]) + (tell (tell NSOpenGLPixelFormat alloc) + initWithAttributes: #:type (_list i _int) + (append + (if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null) + (if (send conf get-stereo) (list NSOpenGLPFAStereo) null) + (list + NSOpenGLPFADepthSize (send conf get-depth-size) + NSOpenGLPFAStencilSize (send conf get-stencil-size) + NSOpenGLPFAAccumSize (send conf get-accum-size)) + (let ([ms (send conf get-multisample-size)]) + (if (zero? ms) + null + (list NSOpenGLPFAMultisample + NSOpenGLPFASampleBuffers 1 + NSOpenGLPFASamples ms))) + (list 0))))) + + +(define-struct scroller (cocoa [range #:mutable] [page #:mutable])) +(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) + +(define canvas% + (canvas-mixin + (class (canvas-autoscroll-mixin window%) + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) + + (inherit get-cocoa get-cocoa-window + get-eventspace + make-graphics-context + is-shown-to-root? + is-shown-to-before-root? + is-enabled-to-root? + is-window-enabled? + block-mouse-events + move get-x get-y + on-size + register-as-child + get-size get-position + set-focus + client-to-screen + is-auto-scroll? get-virtual-width get-virtual-height + reset-auto-scroll + refresh-for-autoscroll) + + (define vscroll-ok? (and (memq 'vscroll style) #t)) + (define vscroll? vscroll-ok?) + (define hscroll-ok? (and (memq 'hscroll style) #t)) + (define hscroll? hscroll-ok?) + + (define wants-focus? (not (memq 'no-focus style))) + (define is-combo? (memq 'combo style)) + (define has-control-border? (and (not is-combo?) + (memq 'control-border style))) + + (define-values (x-margin y-margin x-sb-margin y-sb-margin) + (cond + [has-control-border? (values 3 3 3 3)] + [(memq 'border style) (values 1 1 0 0)] + [else (values 0 0 0 0)])) + + (define canvas-style style) + + (define/override (focus-is-on on?) + (when has-control-border? + (tellv cocoa setFocusState: #:type _BOOL on?) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) + (super focus-is-on on?)) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (unless is-gl? + (request-flush-delay (get-cocoa-window)))) + (define/public (cancel-canvas-flush-delay req) + (unless is-gl? + (cancel-flush-delay req))) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (paint-or-queue-paint) + (or (do-canvas-backing-flush #f) + (begin + (queue-paint) + #f))) + + (define/public (do-canvas-backing-flush ctx) + (do-backing-flush this dc (tell NSGraphicsContext currentContext) + (if is-combo? 2 0) (if is-combo? 2 0))) + + ;; not used, because Cocoa canvas refreshes do not go through + ;; the eventspace queue: + (define/public (schedule-periodic-backing-flush) + (void)) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + (define/public (get-flush-window) + (get-cocoa-window)) + + (define/override (refresh) + ;; can be called from any thread, including the event-pump thread + (queue-paint)) + + (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) + (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) + + (define/override (get-cocoa-content) content-cocoa) + + (define is-gl? (and (not is-combo?) (memq 'gl style))) + (define/public (can-gl?) is-gl?) + + (super-new + [parent parent] + [cocoa + (as-objc-allocation + (tell (tell (cond + [is-combo? NSView] + [has-control-border? FocusView] + [(memq 'border style) (if (memq 'vscroll style) + CornerlessFrameView + FrameView)] + [else NSView]) + alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize (max w (* 2 x-margin)) + (max h (* 2 y-margin))))))] + [no-show? (memq 'deleted style)]) + + (define cocoa (get-cocoa)) + + (define content-cocoa + (let ([r (make-NSRect (make-NSPoint 0 0) + (make-NSSize (max 0 (- w (* 2 x-margin))) + (max 0 (- h (* 2 y-margin)))))]) + (as-objc-allocation + (if (or is-combo? (not (memq 'gl style))) + (tell (tell (if is-combo? MyComboBox MyView) alloc) + initWithFrame: #:type _NSRect r) + (let ([pf (gl-config->pixel-format gl-config)]) + (begin0 + (tell (tell MyGLView alloc) + initWithFrame: #:type _NSRect r + pixelFormat: pf) + (tellv pf release))))))) + (tell #:type _void cocoa addSubview: content-cocoa) + (set-ivar! content-cocoa wxb (->wxb this)) + + (when is-combo? + (tellv content-cocoa setEditable: #:type _BOOL #f) + (tellv content-cocoa setDelegate: content-cocoa) + (install-control-font content-cocoa #f)) + + (define dc (make-object dc% this)) + + (send dc start-backing-retained) + + (queue-paint) + + (define/public (get-dc) dc) + + (define/public (make-compatible-bitmap w h) + (make-object quartz-bitmap% w h)) + + (define/override (fix-dc [refresh? #t]) + (when (dc . is-a? . dc%) + (send dc reset-backing-retained) + (send dc set-auto-scroll + (if (is-auto-scroll?) (scroll-pos h-scroller) 0) + (if (is-auto-scroll?) (scroll-pos v-scroller) 0))) + (when refresh? (refresh))) + + (define/override (get-client-size xb yb) + (super get-client-size xb yb) + (when is-combo? + (set-box! yb (max 0 (- (unbox yb) 5))))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/public (on-paint) (void)) + + (define/override (set-size x y w h) + (do-set-size x y w h)) + + (define tr 0) + + (define/override (show on?) + ;; FIXME: what if we're in the middle of an on-paint? + (super show on?) + (fix-dc)) + + (define/override (hide-children) + (super hide-children) + (suspend-all-reg-blits)) + + (define/override (show-children) + (super show-children) + (resume-all-reg-blits)) + + (define/override (fixup-locations-children) + ;; in atomic mode + (suspend-all-reg-blits) + (resume-all-reg-blits)) + + (define/private (do-set-size x y w h) + (when (pair? blits) + (atomically (suspend-all-reg-blits))) + (super set-size x y w h) + (when tr + (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) + (set! tr #f)) + (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin) + (- h (if hscroll? scroll-width 0) y-margin y-margin))] + [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))]) + (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) + (set! tr (tell #:type _NSInteger + content-cocoa + addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz) + owner: content-cocoa + userData: #f + assumeInside: #:type _BOOL #f))) + (when v-scroller + (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint (- w scroll-width x-sb-margin) + (+ (if hscroll? + scroll-width + 0) + y-sb-margin)) + (make-NSSize scroll-width + (max 0 (- h (if hscroll? scroll-width 0) + x-sb-margin x-sb-margin)))))) + (when h-scroller + (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint x-sb-margin y-sb-margin) + (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) + x-sb-margin x-sb-margin)) + scroll-width)))) + (when (and (pair? blits) + (is-shown-to-root?)) + (atomically (resume-all-reg-blits))) + (fix-dc) + (when (is-auto-scroll?) + (reset-auto-scroll 0 0)) + (on-size 0 0)) + + (define/public (show-scrollbars h? v?) + (let ([h? (and h? hscroll-ok?)] + [v? (and v? vscroll-ok?)]) + (unless (and (eq? h? hscroll?) + (eq? v? vscroll?)) + (cond + [(and h? (not hscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))] + [(and hscroll? (not h?)) + (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)]) + (set! hscroll? h?) + (cond + [(and v? (not vscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))] + [(and vscroll? (not v?)) + (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) + (set! vscroll? v?) + (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)]) + (get-position x y) + (get-size w h) + (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) + + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) + + (define/override (reset-dc-for-autoscroll) + (fix-dc)) + + (define/private (update which scroll- v) + (if (eq? which 'vertical) + (scroll- v-scroller v) + (scroll- h-scroller v))) + + (define/public (set-scroll-page which v) + (update which scroll-page v)) + (define/public (set-scroll-range which v) + (update which scroll-range v)) + (define/public (set-scroll-pos which v) + (update which scroll-pos v)) + + (define/private (guard-scroll which v) + (if (is-auto-scroll?) + 0 + v)) + + (define/public (get-scroll-page which) + (guard-scroll which + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))) + (define/public (get-scroll-range which) + (guard-scroll which + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))) + (define/public (get-scroll-pos which) + (guard-scroll which + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))) + + (define v-scroller + (and vscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint (- w scroll-width x-sb-margin) + (+ (if hscroll? + scroll-width + 0) + y-sb-margin)) + (make-NSSize scroll-width + (max (- h (if hscroll? scroll-width 0) + y-sb-margin y-sb-margin) + (+ scroll-width 10)))))) + 1 + 1))) + (define h-scroller + (and hscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint x-sb-margin y-sb-margin) + (make-NSSize (max (- w (if vscroll? scroll-width 0) + x-sb-margin x-sb-margin) + (+ scroll-width 10)) + scroll-width)))) + 1 + 1))) + + (when v-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller)) + (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:))) + (when h-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller)) + (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:))) + + (define scroll-pos + (case-lambda + [(scroller val) + (when scroller + (tellv (scroller-cocoa scroller) setFloatValue: + #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller)))) + 0.0)))] + [(scroller) + (if scroller + (->long (round (* (tell #:type _float (scroller-cocoa scroller) floatValue) + (scroller-range scroller)))) + 0)])) + + (define scroll-range + (case-lambda + [(scroller val) + (when scroller + (let ([pos (scroll-pos scroller)] + [page (scroll-page scroller)]) + (set-scroller-range! scroller val) + (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val)) + (scroll-pos scroller pos) + (scroll-page scroller page)))] + [(scroller) + (if scroller + (scroller-range scroller) + 1)])) + + (define scroll-page + (case-lambda + [(scroller val) + (when scroller + (set-scroller-page! scroller val) + (let ([proportion + (max (min 1.0 (/ val + (+ val (exact->inexact (scroller-range scroller))))) + 0.0)]) + (if old-cocoa? + (tellv (scroller-cocoa scroller) + setFloatValue: #:type _float (tell #:type _float (scroller-cocoa scroller) + floatValue) + knobProportion: #:type _CGFloat proportion) + (tellv (scroller-cocoa scroller) setKnobProportion: + #:type _CGFloat proportion))))] + [(scroller) + (if scroller + (scroller-page scroller) + 1)])) + + (define/override (enable-window on?) + ;; in atomic mode + (let ([on? (and on? (is-window-enabled?))]) + (let ([w (tell content-cocoa window)]) + (when (ptr-equal? content-cocoa (tell w firstResponder)) + (tellv w makeFirstResponder: #f))) + (block-mouse-events (not on?)) + (when is-combo? + (tellv content-cocoa setEnabled: #:type _BOOL on?)))) + + (define/public (clear-combo-items) + (tellv content-cocoa removeAllItems)) + (define/public (append-combo-item str) + (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) + #t) + (define/public (on-combo-select i) (void)) + + (define clear-bg? (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)))) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if (memq 'transparent canvas-style) + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col)) + (define/public (get-canvas-background-for-clearing) + (and clear-bg? + bg-col)) + + (define/public (reject-partial-update r) + ;; Called in the event-pump thread. + ;; A transparent canvas cannot handle a partial update. + (and (or + ;; Multiple clipping rects? + (let ([i (malloc _NSInteger)] + [r (malloc 'atomic _pointer)]) + (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r + count: #:type _pointer i) + ((ptr-ref i _NSInteger) . > . 1)) + ;; Single clipping not whole area? + (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))] + [s2 (NSRect-size r)]) + (or ((NSSize-width s2) . < . (NSSize-width s1)) + ((NSSize-height s2) . < . (NSSize-height s1))))) + (begin + (queue-window-event this (lambda () (refresh))) + #t))) + + (define/public (do-scroll direction scroller) + ;; Called from the Cocoa handler thread + (let ([part (tell #:type _int scroller hitPart)]) + (queue-window-event + this + (lambda () + (let ([kind + (cond + [(= part NSScrollerDecrementPage) + (set-scroll-pos direction (- (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-up] + [(= part NSScrollerIncrementPage) + (set-scroll-pos direction (+ (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-down] + [(= part NSScrollerDecrementLine) + (set-scroll-pos direction (- (get-scroll-pos direction) 1)) + 'line-up] + [(= part NSScrollerIncrementLine) + (set-scroll-pos direction (+ (get-scroll-pos direction) 1)) + 'line-down] + [(= part NSScrollerKnob) + 'thumb] + [else #f])]) + (when kind + (if (is-auto-scroll?) + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type kind] + [direction direction] + [position (get-scroll-pos direction)])))))))) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void))) + (define/public (on-scroll e) (void)) + + (define/override (definitely-wants-event? e) + ;; Called in Cocoa event-handling mode + (when (and wants-focus? + (e . is-a? . mouse-event%) + (send e button-down? 'left)) + (set-focus)) + (or (not is-combo?) + (e . is-a? . key-event%) + (not (send e button-down? 'left)) + (not (on-menu-click? e)))) + + (define/override (gets-focus?) + wants-focus?) + (define/override (can-be-responder?) + (and wants-focus? (is-enabled-to-root?))) + + (define/private (on-menu-click? e) + ;; Called in Cocoa event-handling mode + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + ((send e get-x) . > . (- (unbox xb) 22)))) + + (define/public (on-popup) (void)) + + (define/public (starting-combo) + (set! in-menu-click? #t) + (tellv content-cocoa setStringValue: #:type _NSString current-text) + (constrained-reply (get-eventspace) + (lambda () (on-popup)) + (void))) + + (define/public (ending-combo) + (set! in-menu-click? #f) + (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) + (when (pos . > . -1) + (queue-window-event this (lambda () (on-combo-select pos))))) + (refresh)) + + (define current-text "") + (define/public (set-combo-text t) + (set! current-text t)) + + (define in-menu-click? #f) + + (define/public (during-menu-click?) + ;; Called in Cocoa event-handling mode + in-menu-click?) + + (define/public (scroll x y) + (when (is-auto-scroll?) + (when (x . >= . 0) (scroll-pos h-scroller (floor (* x (scroll-range h-scroller))))) + (when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller))))) + (refresh-for-autoscroll))) + + (define/public (warp-pointer x y) (void)) + + (define/override (get-virtual-h-pos) + (scroll-pos h-scroller)) + + (define/override (get-virtual-v-pos) + (scroll-pos v-scroller)) + + (define/public (set-resize-corner on?) + (void)) + + (define/public (get-backing-size xb yb) + (get-client-size xb yb) + (when is-combo? + (set-box! xb (- (unbox xb) 22)))) + + (define/override (get-cursor-width-delta) + (if is-combo? 22 0)) + + (define/public (is-flipped?) + (tell #:type _BOOL (get-cocoa-content) isFlipped)) + + (define blits null) + (define reg-blits null) + + (define/private (suspend-all-reg-blits) + (let ([cocoa-win (get-cocoa-window)]) + (for ([r (in-list reg-blits)]) + (tellv cocoa-win removeChildWindow: (car r)) + (release (car r)) + (scheme_remove_gc_callback (cdr r)))) + (set! reg-blits null)) + + (define/public (resume-all-reg-blits) + (unless (pair? reg-blits) + (when (pair? blits) + (set! reg-blits + (for/list ([b (in-list blits)]) + (let-values ([(x y w h img) (apply values b)]) + (register-one-blit x y w h img))))))) + + (define/private (register-one-blit x y w h img) + (let ([xb (box x)] + [yb (box y)]) + (client-to-screen xb yb #f) + (let* ([cocoa-win (get-cocoa-window)]) + (atomically + (let ([win (as-objc-allocation + (tell (tell NSWindow alloc) + initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) + (- (unbox yb) + h)) + (make-NSSize w h)) + styleMask: #:type _int NSBorderlessWindowMask + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))] + [iv (tell (tell NSImageView alloc) init)]) + (tellv iv setImage: img) + (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))) + (tellv (tell win contentView) addSubview: iv) + (tellv win setAlphaValue: #:type _CGFloat 0.0) + (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) + (tellv iv release) + (let ([r (scheme_add_gc_callback + (make-gc-action-desc win (selector setAlphaValue:) 1.0) + (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) + (cons win r))))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (fix-bitmap-size on w h on-x on-y)]) + (let ([img (bitmap->image on)]) + (atomically + (set! blits (cons (list x y w h img) blits)) + (when (is-shown-to-root?) + (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + + (define/public (unregister-collecting-blits) + (atomically + (suspend-all-reg-blits) + (set! blits null)))))) diff --git a/collects/mred/private/wx/cocoa/cg.rkt b/collects/mred/private/wx/cocoa/cg.rkt new file mode 100644 index 00000000..b158602a --- /dev/null +++ b/collects/mred/private/wx/cocoa/cg.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "types.rkt" + "utils.rkt") + +(provide (protect-out (all-defined-out))) + +(define _CGContextRef (_cpointer 'CGContextRef)) +(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) +(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) +(define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) +(define-appserv CGContextRotateCTM (_fun _CGContextRef _CGFloat -> _void)) +(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) +(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) +(define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) +(define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) +(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) diff --git a/collects/mred/private/wx/cocoa/check-box.rkt b/collects/mred/private/wx/cocoa/check-box.rkt new file mode 100644 index 00000000..cd2ed74a --- /dev/null +++ b/collects/mred/private/wx/cocoa/check-box.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + "../../syntax.rkt" + "button.rkt" + "types.rkt" + "const.rkt") + +(provide + (protect-out check-box%)) + +;; ---------------------------------------- + +(defclass check-box% core-button% + (inherit get-cocoa) + (super-new [button-type NSSwitchButton] + [event-type 'check-box]) + + (define/public (set-value v) + (tellv (get-cocoa) setState: #:type _NSInteger (if v 1 0))) + (define/public (get-value) + (positive? (tell #:type _NSInteger (get-cocoa) state)))) + diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt new file mode 100644 index 00000000..844748e4 --- /dev/null +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -0,0 +1,73 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "item.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt") + +(provide + (protect-out choice%)) + +;; ---------------------------------------- + +(import-class NSPopUpButton) + +(define-objc-class MyPopUpButton NSPopUpButton + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (clicked: [_id sender]) + (queue-window*-event wxb (lambda (wx) (send wx clicked))))) + +(defclass choice% item% + (init parent cb label + x y w h + choices style font) + (inherit get-cocoa init-font register-as-child) + + (super-new [parent parent] + [cocoa + (let ([cocoa + (as-objc-allocation + (tell (tell MyPopUpButton alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize w h)) + pullsDown: #:type _BOOL #f))]) + (for ([lbl (in-list choices)] + [i (in-naturals)]) + (tellv cocoa + insertItemWithTitle: #:type _NSString lbl + atIndex: #:type _NSInteger i)) + (init-font cocoa font) + (tellv cocoa sizeToFit) + (tellv cocoa setTarget: cocoa) + (tellv cocoa setAction: #:type _SEL (selector clicked:)) + cocoa)] + [callback cb] + [no-show? (memq 'deleted style)]) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))) + + (define/public (set-selection i) + (tellv (get-cocoa) selectItemAtIndex: #:type _NSInteger i)) + (define/public (get-selection) + (tell #:type _NSInteger (get-cocoa) indexOfSelectedItem)) + (define/public (number) + (tell #:type _NSInteger (get-cocoa) numberOfItems)) + (define/public (clear) + (tellv (get-cocoa) removeAllItems)) + (define/public (append lbl) + (tellv (get-cocoa) + insertItemWithTitle: #:type _NSString lbl + atIndex: #:type _NSInteger (number))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt new file mode 100644 index 00000000..34eb2370 --- /dev/null +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -0,0 +1,98 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt" + "image.rkt" + racket/draw/unsafe/bstr + "../../syntax.rkt" + "../../lock.rkt") + +(provide + (protect-out clipboard-driver% + has-x-selection?)) + +(import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext) +(import-protocol NSPasteboardOwner) + +(define (has-x-selection?) #f) + +(define (map-type s) + (cond + [(string=? s "TEXT") "public.utf8-plain-text"] + [else (string-append "org.racket-lang." s)])) + +(define (unmap-type s) + (cond + [(string=? s "public.utf8-plain-text") "TEXT"] + [(regexp-match #rx"^org[.]racket-lang[.](.*)$" s) + => (lambda (m) (cadr m))] + [else s])) + +(defclass clipboard-driver% object% + (init x-selection?) ; always #f + (super-new) + + (define client #f) + (define counter -1) + + (define/public (clear-client) + ;; called in event-pump thread + (set! client #f)) + + (define/public (get-client) + (and client + (let ([c (tell #:type _NSInteger (tell NSPasteboard generalPasteboard) + changeCount)]) + (if (= c counter) + client + (begin + (set! client #f) + #f))))) + + (define/public (set-client c types) + (atomically + (with-autorelease + (let ([pb (tell NSPasteboard generalPasteboard)] + [a (tell NSArray arrayWithObjects: + #:type (_list i _NSString) (map map-type types) + count: #:type _NSUInteger (length types))]) + (set! counter (tell #:type _NSInteger pb + declareTypes: a + owner: #f)) + (set! client c) + (for ([type (in-list types)]) + (let* ([bstr (send c get-data type)] + [data (tell NSData + dataWithBytes: #:type _bytes bstr + length: #:type _NSUInteger (bytes-length bstr))]) + (tellv (tell NSPasteboard generalPasteboard) + setData: data + forType: #:type _NSString (map-type type)))))))) + + (define/public (get-data-for-type type) + (log-error "didn't expect clipboard data request")) + + (define/public (get-text-data) + (let ([bstr (get-data "TEXT")]) + (and bstr + (bytes->string/utf-8 bstr #\?)))) + + (define/public (get-data type) + (atomically + (with-autorelease + (let* ([pb (tell NSPasteboard generalPasteboard)] + [data (tell pb dataForType: #:type _NSString (map-type type))]) + (and data + (let ([len (tell #:type _NSUInteger data length)] + [bstr (tell #:type _pointer data bytes)]) + (scheme_make_sized_byte_string bstr len 1))))))) + + (define/public (get-bitmap-data) + (atomically + (with-autorelease + (let ([i (tell (tell NSImage alloc) + initWithPasteboard: (tell NSPasteboard generalPasteboard))]) + (and i + (image->bitmap i))))))) diff --git a/collects/mred/private/wx/cocoa/colordialog.rkt b/collects/mred/private/wx/cocoa/colordialog.rkt new file mode 100644 index 00000000..2dc750c3 --- /dev/null +++ b/collects/mred/private/wx/cocoa/colordialog.rkt @@ -0,0 +1,44 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/draw/private/color + "../../lock.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out get-color-from-user)) + +(import-class NSColorPanel + NSColor) + +(define-cocoa NSDeviceRGBColorSpace _id) + +(define (get-color-from-user mode) + (cond + [(eq? mode 'show) + (tellv (tell NSColorPanel sharedColorPanel) + orderFront: #f)] + [(eq? mode 'get) + (atomically + (let ([c (tell (tell (tell NSColorPanel sharedColorPanel) color) + colorUsingColorSpaceName: NSDeviceRGBColorSpace)] + [as-color (lambda (v) + (inexact->exact (floor (* 255.0 v))))]) + (make-object color% + (as-color + (tell #:type _CGFloat c redComponent)) + (as-color + (tell #:type _CGFloat c greenComponent)) + (as-color + (tell #:type _CGFloat c blueComponent)))))] + [else + (let ([p (tell NSColorPanel sharedColorPanel)] + [color mode]) + (atomically + (tellv p setColor: (tell NSColor + colorWithDeviceRed: #:type _CGFloat (/ (color-red color) 255.0) + green: #:type _CGFloat (/ (color-green color) 255.0) + blue: #:type _CGFloat (/ (color-blue color) 255.0) + alpha: #:type _CGFloat 1.0))))])) diff --git a/collects/mred/private/wx/cocoa/const.rkt b/collects/mred/private/wx/cocoa/const.rkt new file mode 100644 index 00000000..d2f99cb3 --- /dev/null +++ b/collects/mred/private/wx/cocoa/const.rkt @@ -0,0 +1,126 @@ +#lang racket/base + +(provide (except-out (all-defined-out) <<)) + +(define (<< a b) (arithmetic-shift a b)) + +(define NSTitledWindowMask 1) +(define NSBorderlessWindowMask 0) +(define NSClosableWindowMask 2) +(define NSMiniaturizableWindowMask 4) +(define NSResizableWindowMask 8) +(define NSUtilityWindowMask (1 . << . 4)) +(define NSTexturedBackgroundWindowMask 256) + +(define NSBackingStoreBuffered 2) +(define NSRoundedBezelStyle 1) +(define NSRegularSquareBezelStyle 2) + +(define NSAnyEventMask #xffffffff) + +(define NSLeftMouseDown 1) +(define NSLeftMouseUp 2) +(define NSRightMouseDown 3) +(define NSRightMouseUp 4) +(define NSMouseMoved 5) +(define NSLeftMouseDragged 6) +(define NSRightMouseDragged 7) +(define NSMouseEntered 8) +(define NSMouseExited 9) +(define NSKeyDown 10) +(define NSKeyUp 11) +(define NSFlagsChanged 12) +(define NSAppKitDefined 13) +(define NSSystemDefined 14) +(define NSApplicationDefined 15) +(define NSPeriodic 16) +(define NSCursorUpdate 17) +(define NSScrollWheel 22) +(define NSTabletPoint 23) +(define NSTabletProximity 24) +(define NSOtherMouseDown 25) +(define NSOtherMouseUp 26) +(define NSOtherMouseDragged 27) +(define NSEventTypeGesture 29) +(define NSEventTypeMagnify 30) +(define NSEventTypeSwipe 31) +(define NSEventTypeRotate 18) +(define NSEventTypeBeginGesture 19) +(define NSEventTypeEndGesture 20) + +(define MouseAndKeyEventMask + (bitwise-ior + (1 . << . NSLeftMouseDown) + (1 . << . NSLeftMouseUp) + (1 . << . NSRightMouseDown) + (1 . << . NSRightMouseUp) + (1 . << . NSMouseMoved) + (1 . << . NSLeftMouseDragged) + (1 . << . NSRightMouseDragged) + (1 . << . NSMouseEntered) + (1 . << . NSMouseExited) + (1 . << . NSKeyDown) + (1 . << . NSKeyUp) + (1 . << . NSScrollWheel) + (1 . << . NSTabletPoint) + (1 . << . NSTabletProximity) + (1 . << . NSOtherMouseDown) + (1 . << . NSOtherMouseUp) + (1 . << . NSOtherMouseDragged) + (1 . << . NSEventTypeGesture) + (1 . << . NSEventTypeMagnify) + (1 . << . NSEventTypeSwipe) + (1 . << . NSEventTypeRotate) + (1 . << . NSEventTypeBeginGesture) + (1 . << . NSEventTypeEndGesture))) + +(define NSAlphaShiftKeyMask (1 . << . 16)) +(define NSShiftKeyMask (1 . << . 17)) +(define NSControlKeyMask (1 . << . 18)) +(define NSAlternateKeyMask (1 . << . 19)) +(define NSCommandKeyMask (1 . << . 20)) +(define NSNumericPadKeyMask (1 . << . 21)) +(define NSHelpKeyMask (1 . << . 22)) +(define NSFunctionKeyMask (1 . << . 23)) + +(define NSScrollerNoPart 0) +(define NSScrollerDecrementPage 1) +(define NSScrollerKnob 2) +(define NSScrollerIncrementPage 3) +(define NSScrollerDecrementLine 4) +(define NSScrollerIncrementLine 5) +(define NSScrollerKnobSlot 6) + +(define NSMomentaryLightButton 0) +(define NSPushOnPushOffButton 1) +(define NSToggleButton 2) +(define NSSwitchButton 3) +(define NSRadioButton 4) +(define NSMomentaryChangeButton 5) +(define NSOnOffButton 6) +(define NSMomentaryPushInButton 7) +(define NSMomentaryPushButton 0) +(define NSMomentaryLight 7) + +(define NSFocusRingTypeDefault 0) +(define NSFocusRingTypeNone 1) +(define NSFocusRingTypeExterior 2) + +(define kCGBitmapAlphaInfoMask #x1F) +(define kCGBitmapFloatComponents (1 . << . 8)) +(define kCGBitmapByteOrderMask #x7000) +(define kCGBitmapByteOrderDefault (0 . << . 12)) +(define kCGBitmapByteOrder16Little (1 . << . 12)) +(define kCGBitmapByteOrder32Little (2 . << . 12)) +(define kCGBitmapByteOrder16Big (3 . << . 12)) +(define kCGBitmapByteOrder32Big (4 . << . 12)) + +(define kCGImageAlphaNone 0) +(define kCGImageAlphaPremultipliedLast 1) +(define kCGImageAlphaPremultipliedFirst 2) +(define kCGImageAlphaLast 3) +(define kCGImageAlphaFirst 4) +(define kCGImageAlphaNoneSkipLast 5) +(define kCGImageAlphaNoneSkipFirst 6) + + diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt new file mode 100644 index 00000000..0ca120c1 --- /dev/null +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -0,0 +1,87 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/draw + "image.rkt" + "types.rkt" + "utils.rkt" + "../common/cursor-draw.rkt" + "../common/local.rkt") + +(provide + (protect-out cursor-driver% + arrow-cursor-handle + get-wait-cursor-handle)) + +(import-class NSCursor) + +(define wait #f) +(define bullseye #f) +(define blank #f) +(define size-ne/sw #f) +(define size-nw/se #f) + +(define-syntax-rule (image-cursor id draw-proc) + (or id + (begin + (set! id (make-image-cursor draw-proc)) + id))) + +(define (make-image-cursor draw-proc) + (let* ([bm (make-cursor-image draw-proc)]) + (let ([image (bitmap->image bm)]) + (tell (tell NSCursor alloc) + initWithImage: image + hotSpot: #:type _NSPoint (make-NSPoint 8 8))))) + +(define arrow-cursor-handle (tell NSCursor arrowCursor)) +(define (get-wait-cursor-handle) + (image-cursor wait draw-watch)) + +(define cursor-driver% + (class object% + (define handle #f) + + (define/public (set-standard sym) + (case sym + [(arrow) + (set! handle arrow-cursor-handle)] + [(cross) + (set! handle (tell NSCursor crosshairCursor))] + [(hand) + (set! handle (tell NSCursor openHandCursor))] + [(ibeam) + (set! handle (tell NSCursor IBeamCursor))] + [(size-n/s) + (set! handle (tell NSCursor resizeUpDownCursor))] + [(size-e/w) + (set! handle (tell NSCursor resizeLeftRightCursor))] + [(size-nw/se) + (set! handle (image-cursor size-nw/se draw-nw/se))] + [(size-ne/sw) + (set! handle (image-cursor size-ne/sw draw-ne/sw))] + [(watch) + (set! handle (get-wait-cursor-handle))] + [(bullseye) + (set! handle (image-cursor bullseye draw-bullseye))] + [(blank) + (set! handle (image-cursor blank void))])) + + (define/public (set-image image mask hot-spot-x hot-spot-y) + (let ([bm (make-object bitmap% 16 16 #f #t)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask) + (send dc set-bitmap #f)) + (let ([image (bitmap->image bm)]) + (set! handle + (as-objc-allocation + (tell (tell NSCursor alloc) + initWithImage: image + hotSpot: #:type _NSPoint (make-NSPoint hot-spot-x hot-spot-y))))))) + + (define/public (ok?) (and handle #t)) + + (define/public (get-handle) handle) + + (super-new))) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt new file mode 100644 index 00000000..b739fa88 --- /dev/null +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -0,0 +1,101 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + racket/draw/unsafe/cairo + racket/draw/private/bitmap + racket/draw/private/local + racket/draw/private/gl-context + "types.rkt" + "utils.rkt" + "bitmap.rkt" + "window.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "../common/backing-dc.rkt" + "cg.rkt") + +(provide + (protect-out dc% + do-backing-flush)) + +(import-class NSOpenGLContext) + +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (define canvas cnvs) + + (inherit end-delay) + (super-new) + + (define gl #f) + (define/override (get-gl-context) + (and (send canvas can-gl?) + (let ([gl-ctx (tell (send canvas get-cocoa-content) openGLContext)]) + (or gl + (let ([g (new (class gl-context% + (define/override (do-call-as-current t) + (dynamic-wind + (lambda () (tellv gl-ctx makeCurrentContext)) + t + (lambda () (tellv NSOpenGLContext clearCurrentContext)))) + (define/override (do-swap-buffers) + (tellv gl-ctx flushBuffer)) + (super-new)))]) + (set! gl g) + g))))) + + ;; Use a quartz bitmap so that text looks good: + (define/override (make-backing-bitmap w h) (make-object quartz-bitmap% w h)) + (define/override (can-combine-text? sz) #t) + + (define/override (get-backing-size xb yb) + (send canvas get-backing-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) + (send canvas queue-backing-flush)) + + (define/override (flush) + (send canvas flush)) + + (define/override (request-delay) + (send canvas request-canvas-flush-delay)) + (define/override (cancel-delay req) + (send canvas cancel-canvas-flush-delay req)))) + +(define (do-backing-flush canvas dc ctx dx dy) + (tellv ctx saveGraphicsState) + (begin0 + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (unless (send canvas is-flipped?) + (CGContextTranslateCTM cg 0 (unbox h)) + (CGContextScaleCTM cg 1 -1)) + (CGContextTranslateCTM cg dx dy) + (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) + (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/cocoa/dialog.rkt b/collects/mred/private/wx/cocoa/dialog.rkt new file mode 100644 index 00000000..bfb8517e --- /dev/null +++ b/collects/mred/private/wx/cocoa/dialog.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt" + "../common/queue.rkt" + "../common/dialog.rkt" + "../../lock.rkt" + "frame.rkt") + +(provide + (protect-out dialog%)) + +(define dialog% + (class (dialog-mixin frame%) + (super-new [is-dialog? #t]) + + ;; #t result avoids children sheets + (define/override (get-sheet) #t))) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt new file mode 100644 index 00000000..3e6d35d1 --- /dev/null +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -0,0 +1,102 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/path + "../../lock.rkt" + "utils.rkt" + "types.rkt" + "queue.rkt" + "frame.rkt") + +(provide + (protect-out file-selector)) + +(import-class NSOpenPanel NSSavePanel NSURL NSArray) + +(define (nsurl->string url) + (string->path (tell #:type _NSString url path))) + +(define (file-selector message directory filename + extension + filters style parent) + (let ([ns (as-objc-allocation-with-retain + (if (memq 'put style) + (tell NSSavePanel savePanel) + (tell NSOpenPanel openPanel)))] + [parent (and parent + (not (send parent get-sheet)) + parent)]) + + (let ([extensions (append + (if extension (list extension) null) + (if (memq 'packages style) (list "app") null) + (for/list ([e (in-list filters)] + #:when (and (regexp-match #rx"[*][.][^.]+$" (cadr e)) + (not (equal? (cadr e) "*.*")))) + (car (regexp-match #rx"[^.]+$" (cadr e)))))]) + (unless (null? extensions) + (when (memq 'put style) + (tellv ns setCanSelectHiddenExtension: #:type _BOOL #t)) + (let ([a (tell NSArray + arrayWithObjects: #:type (_list i _NSString) extensions + count: #:type _NSUInteger (length extensions))]) + (tellv ns setAllowedFileTypes: a)) + (let ([others? (ormap (lambda (e) + (equal? (cadr e) "*.*")) + filters)]) + (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)))) + + (cond + [(memq 'multi style) + (tellv ns setAllowsMultipleSelection: #:type _BOOL #t)] + [(memq 'dir style) + (tellv ns setCanChooseDirectories: #:type _BOOL #t) + (tellv ns setCanChooseFiles: #:type _BOOL #f)]) + + (when message + (tellv ns setMessage: #:type _NSString message)) + (when directory + (let ([dir (if (string? directory) + directory + (path->string directory))]) + (if (version-10.6-or-later?) + (tellv ns setDirectoryURL: (tell NSURL + fileURLWithPath: #:type _NSString dir + isDirectory: #:type _BOOL #t)) + (tellv ns setDirectory: #:type _NSString dir)))) + (when filename + (when (version-10.6-or-later?) + (tellv ns setNameFieldStringValue: #:type _NSString (path->string + (file-name-from-path filename))))) + + (when (memq 'enter-packages style) + (tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t)) + + (let ([result + ;; We run the file dialog completely modally --- shutting out + ;; all other eventspaces and threads. It would be nice to improve + ;; on this, but it's good enough. + (atomically + (let ([front (get-front)] + [parent (and (version-10.6-or-later?) + parent)]) + (when parent + (tellv ns beginSheetModalForWindow: (send parent get-cocoa-window) + completionHandler: #f)) + (begin0 + (tell #:type _NSInteger ns runModal) + (when parent (tell app endSheet: ns)) + (when front (tellv (send front get-cocoa-window) + makeKeyAndOrderFront: #f)))))]) + (begin0 + (if (zero? result) + #f + (if (memq 'multi style) + (let ([urls (tell ns URLs)]) + (for/list ([i (in-range (tell #:type _NSUInteger urls count))]) + (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) + (let ([url (tell ns URL)]) + (nsurl->string url)))) + (release ns))))) + diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt new file mode 100644 index 00000000..300386ef --- /dev/null +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -0,0 +1,148 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + "utils.rkt" + "types.rkt") + +(provide + (protect-out file-creator-and-type)) + +(define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices"))) + +(define-ffi-definer define-coreserv coreserv-lib) + +(define kFSCatInfoFinderInfo #x00000800) +(define _FSCatalogInfoBitmap _uint32) + +(define _FSVolumeRefNum _int16) + +(define-cstruct _UTCDateTime + ([highSeconds _uint16] + [lowSeconds _uint32] + [fraction _uint16]) + #:alignment 2) + +(define-cstruct _Point + ([v _short] + [h _short])) + +(define _OSType _uint32) + +(define-cstruct _FileInfo + ([fileType _OSType] + [fileCreator _OSType] + [finderFlags _uint16] + [location _Point] + [reservedField _uint16]) + #:alignment 2) + +(define-cstruct _FSPermissionInfo + ([userID _uint32] + [groupID _uint32] + [word _uint32] + [fileSec _pointer]) + #:alignment 2) + +(define-cstruct _FSCatalogInfo + ([nodeFlags _uint16] + [volume _FSVolumeRefNum] + [parentDirID _uint32] + [nodeID _uint32] + [sharingFlags _uint8] + [userPrivileges _uint8] + [reserved1 _uint8] + [reserved2 _uint8] + [createDate _UTCDateTime] + [contentModDate _UTCDateTime] + [attributeModDate _UTCDateTime] + [accessDate _UTCDateTime] + [backupDate _UTCDateTime] + [permissions _FSPermissionInfo] + [finderInfo _FileInfo] + ;; .... 144 or 148 bytes total + ) + #:alignment 2) + +(define _FSRef _pointer) ; 80 bytes + +(define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus)) + +(define-coreserv FSGetCatalogInfo + (_fun _FSRef + _FSCatalogInfoBitmap + _FSCatalogInfo-pointer + _pointer ; outname, #f is ok + _pointer ; fsSpec, #f is ok + _pointer ; parentRef, #f is ok + -> _OSStatus)) + +(define-coreserv FSSetCatalogInfo + (_fun _FSRef + _FSCatalogInfoBitmap + _FSCatalogInfo-pointer + -> _OSStatus)) + +(define (path->fsref s) + (let ([fs (malloc 80)]) + (let ([r (FSPathMakeRef s fs)]) + (unless (zero? r) + (error 'file-creator-and-type "could not access file (~a): ~v" + r + s))) + fs)) + +(define (int->str v) + (bytes (arithmetic-shift (bitwise-and v #xFF000000) -24) + (arithmetic-shift (bitwise-and v #xFF0000) -16) + (arithmetic-shift (bitwise-and v #xFF00) -8) + (bitwise-and v #xFF))) + +(define (str->int v) + (bitwise-ior (arithmetic-shift (bytes-ref v 0) 24) + (arithmetic-shift (bytes-ref v 1) 16) + (arithmetic-shift (bytes-ref v 2) 8) + (bytes-ref v 3))) + + +(define (get-info v fs path) + (let ([r (FSGetCatalogInfo fs + kFSCatInfoFinderInfo + v + #f #f #f)]) + (unless (zero? r) + (error 'file-creator-and-type "lookup failed (~a): ~e" + r + path)))) + +(define file-creator-and-type + (case-lambda + [(path) + (unless (path-string? path) + (raise-type-error 'file-creator-and-type "path string" path)) + (let ([info (let ([fs (path->fsref path)] + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) + (get-info v fs path) + (FSCatalogInfo-finderInfo v))]) + (values (int->str (FileInfo-fileCreator info)) + (int->str (FileInfo-fileType info))))] + [(path creator type) + (unless (path-string? path) + (raise-type-error 'file-creator-and-type "path string" path)) + (unless (and (bytes? creator) (= 4 (bytes-length creator))) + (raise-type-error 'file-creator-and-type "bytes string of length 4" creator)) + (unless (and (bytes? type) (= 4 (bytes-length type))) + (raise-type-error 'file-creator-and-type "bytes string of length 4" type)) + (let ([fs (path->fsref path)] + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) + (get-info v fs path) + (let ([info (FSCatalogInfo-finderInfo v)]) + (set-FileInfo-fileCreator! info (str->int creator)) + (set-FileInfo-fileType! info (str->int type))) + (let ([r (FSSetCatalogInfo fs + kFSCatInfoFinderInfo + v)]) + (unless (zero? r) + (error 'file-creator-and-type "change failed (~a): ~e" + r + path)))) + (void)])) diff --git a/collects/mred/private/wx/cocoa/font.rkt b/collects/mred/private/wx/cocoa/font.rkt new file mode 100644 index 00000000..014e0942 --- /dev/null +++ b/collects/mred/private/wx/cocoa/font.rkt @@ -0,0 +1,49 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + ffi/unsafe/objc + "../../lock.rkt" + "const.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out font->NSFont)) + +(import-class NSFont NSFontManager) + +(define NSItalicFontMask #x00000001) +(define NSBoldFontMask #x00000002) + +(define (font->NSFont f) + (let* ([weight (send f get-weight)] + [style (send f get-style)] + [name (or (send f get-face) + (send the-font-name-directory + get-screen-name + (send the-font-name-directory + find-family-default-font-id + (send f get-family)) + weight + style))]) + (atomically + (with-autorelease + (let ([f (tell NSFont + fontWithName: #:type _NSString name + size: #:type _CGFloat (send f get-point-size))]) + (if (and (eq? 'normal weight) + (eq? 'normal style)) + (begin + (retain f) + f) + (let ([fm (tell NSFontManager sharedFontManager)]) + (let ([f (tell fm + convertFont: f + toHaveTrait: #:type _int (bitwise-ior + (if (eq? weight 'bold) NSBoldFontMask 0) + (if (eq? style 'italic) NSItalicFontMask 0)))]) + (begin + (retain f) + f))))))))) + \ No newline at end of file diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt new file mode 100644 index 00000000..ffe008e4 --- /dev/null +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -0,0 +1,560 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + scheme/class + "pool.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "queue.rkt" + "menu-bar.rkt" + "cursor.rkt" + "../../syntax.rkt" + "../common/queue.rkt" + "../common/freeze.rkt" + "../../lock.rkt") + +(provide + (protect-out frame% + location->window + get-front)) + +;; ---------------------------------------- + +(import-class NSWindow NSGraphicsContext NSMenu NSPanel + NSApplication NSAutoreleasePool NSScreen + NSToolbar) + +(define NSWindowCloseButton 0) +(define NSWindowToolbarButton 3) + +(define front #f) + +(define (get-front) front) + +(define empty-mb (new menu-bar%)) +(define root-fake-frame #f) + +;; Maps window numbers to weak boxes of frame objects; +;; the weak-box layer is needed to avoid GC-accounting +;; problems. +(define all-windows (make-hash)) + +(define-objc-mixin (MyWindowMethods Superclass) + [wxb] + [-a _scheme (getEventspace) + (let ([wx (->wx wxb)]) + (and wx (send wx get-eventspace)))] + [-a _BOOL (canBecomeKeyWindow) + (let ([wx (->wx wxb)]) + (and wx + (not (other-modal? wx))))] + [-a _BOOL (canBecomeMainWindow) #t] + [-a _BOOL (windowShouldClose: [_id win]) + (queue-window*-event wxb (lambda (wx) + (unless (other-modal? wx) + (when (send wx on-close) + (atomically + (send wx direct-show #f)))))) + #f] + [-a _void (windowDidResize: [_id notification]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx (lambda () + (send wx on-size 0 0) + (send wx clean-up))) + ;; Live resize: + (constrained-reply (send wx get-eventspace) + (lambda () + (pre-event-sync #t) + (let loop () (when (yield) (loop)))) + (void)))))] + [-a _void (windowDidMove: [_id notification]) + (when wxb + (queue-window*-event wxb (lambda (wx) + (send wx on-size 0 0))))] + [-a _void (windowDidBecomeMain: [_id notification]) + ;; We check whether the window is visible because + ;; clicking the dock item tries to resurrect a hidden + ;; frame. See also `setOneShot' below. + (when (tell #:type _BOOL self isVisible) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (set! front wx) + (send wx install-wait-cursor) + (send wx install-mb) + (send wx notify-responder #t) + (queue-window-event wx (lambda () + (send wx on-activate #t)))))))] + [-a _void (windowDidResignMain: [_id notification]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (when (eq? front wx) + (set! front #f) + (send wx uninstall-wait-cursor)) + (if root-fake-frame + (send root-fake-frame install-mb) + (send empty-mb install)) + (send wx notify-responder #f) + (queue-window-event wx (lambda () + (send wx on-activate #f))))))] + [-a _void (toggleToolbarShown: [_id sender]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (queue-window-event wx + (lambda () (send wx on-toolbar-click)))))) + (void)]) + +(define-objc-class MyWindow NSWindow + #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) + [wxb]) + +(define-objc-class MyPanel NSPanel + #:mixins (FocusResponder KeyMouseResponder MyWindowMethods) + [wxb]) + +(set-front-hook! (lambda () (values front + (and front (send front get-eventspace))))) + +(set-eventspace-hook! (lambda (w) + (or (and w + (if (objc-is-a? w MyWindow) + (tell #:type _scheme w getEventspace) + #f)) + (and front + (send front get-eventspace))))) + +(define frame% + (class window% + (init parent + label + x y w h + style) + (init [is-dialog? #f]) + + (inherit get-cocoa get-parent + get-eventspace + pre-on-char pre-on-event + get-x + on-new-child + is-window-enabled?) + + (super-new [parent parent] + [cocoa + (let ([is-sheet? (and #f + is-dialog? + parent + (not (send parent frame-is-dialog?)))] + [init-rect (make-NSRect (make-init-point x y) + (make-NSSize (max 30 w) + (max (if (memq 'no-caption style) + 0 + 22) + h)))]) + (let ([c (as-objc-allocation + (tell (tell (if is-sheet? + MyPanel + MyWindow) + alloc) + initWithContentRect: #:type _NSRect init-rect + styleMask: #:type _int (if (memq 'no-caption style) + NSBorderlessWindowMask + (bitwise-ior + NSTitledWindowMask + (if is-sheet? NSUtilityWindowMask 0) + (if is-dialog? + (if (memq 'close-button style) + NSClosableWindowMask + 0) + (bitwise-ior + NSClosableWindowMask + NSMiniaturizableWindowMask + (if (memq 'no-resize-border style) + 0 + NSResizableWindowMask))))) + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))]) + ;; use init rect as frame size, not content size + (tellv c setFrame: #:type _NSRect init-rect display: #:type _BOOL #f) + c))] + [no-show? #t]) + (define cocoa (get-cocoa)) + (tellv cocoa setDelegate: cocoa) + + (when (memq 'toolbar-button style) + (atomically + (let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")]) + (tellv cocoa setToolbar: tb) + (tellv tb setVisible: #:type _BOOL #f) + (tellv tb release)))) + + (internal-move -11111 (if (= y -11111) 0 y)) + + (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) + + ;; Setting the window in one-shot mode helps prevent the + ;; frame from being resurrected by a click on the dock icon. + (tellv cocoa setOneShot: #:type _BOOL #t) + + (define/override (get-cocoa-content) + (tell cocoa contentView)) + (define/override (get-cocoa-window) cocoa) + (define/override (get-wx-window) this) + + (define/override (make-graphics-context) + (tell cocoa graphicsContext) + #; + (as-objc-allocation + (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) + + (define is-a-dialog? is-dialog?) + (define/public (frame-is-dialog?) is-a-dialog?) + + (define/public (frame-relative-dialog-status win) #f) + (define/override (get-dialog-level) 0) + + (define/public (clean-up) + ;; When a window is resized, then any drawing that is in flight + ;; might draw outside the canvas boundaries. Just refresh everything. + (tellv cocoa display)) + + (when label + (tellv cocoa setTitle: #:type _NSString label)) + + (define child-sheet #f) + (define/public (get-sheet) child-sheet) + (define/public (set-sheet s) (set! child-sheet s)) + + (define caption? (not (memq 'no-caption style))) + (define/public (can-have-sheet?) caption?) + + (define/public (direct-show on?) + ;; in atomic mode + (when (and (not on?) + (eq? front this)) + (set! front #f) + (send empty-mb install)) + (if on? + (show-children) + (hide-children)) + (if on? + (if (and is-a-dialog? + (let ([p (get-parent)]) + (and p + (send p can-have-sheet?) + (not (send p get-sheet))))) + (let ([p (get-parent)]) + (send p set-sheet this) + (tellv (tell NSApplication sharedApplication) + beginSheet: cocoa + modalForWindow: (send p get-cocoa) + modalDelegate: #f + didEndSelector: #:type _SEL #f + contextInfo: #f)) + (tellv cocoa makeKeyAndOrderFront: #f)) + (begin + (when is-a-dialog? + (let ([p (get-parent)]) + (when (and p + (eq? this (send p get-sheet))) + (send p set-sheet #f) + (tell (tell NSApplication sharedApplication) + endSheet: cocoa)))) + (tellv cocoa orderOut: #f) + (let ([next + (atomically + (with-autorelease + (let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)]) + (begin0 + (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) + (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) + (and (tell #:type _BOOL win isVisible) + (not (tell win parentWindow)) + (or (not root-fake-frame) + (not (ptr-equal? win (send root-fake-frame get-cocoa)))) + win)))))))]) + (cond + [next (tellv next makeKeyWindow)] + [root-fake-frame (send root-fake-frame install-mb)] + [else (void)])))) + (register-frame-shown this on?) + (let ([num (tell #:type _NSInteger cocoa windowNumber)]) + (if on? + (hash-set! all-windows num (make-weak-box this)) + (hash-remove! all-windows num))) + (when on? + (let ([b (eventspace-wait-cursor-count (get-eventspace))]) + (set-wait-cursor-mode (not (zero? b)))))) + + (define/override (show on?) + (let ([es (get-eventspace)]) + (when on? + (when (eventspace-shutdown? es) + (error (string->symbol + (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%))) + "the eventspace hash been shutdown")) + (when saved-child + (if (eq? (current-thread) (eventspace-handler-thread es)) + (do-paint-children) + (let ([s (make-semaphore)]) + (queue-callback (lambda () + (do-paint-children) + (semaphore-post s))) + (sync/timeout 1 s)))))) + (atomically + (direct-show on?))) + + (define/private (do-paint-children) + (when saved-child + (send saved-child paint-children)) + (yield-refresh) + (try-to-sync-refresh)) + + (define/public (destroy) + (when child-sheet (send child-sheet destroy)) + (atomically + (direct-show #f))) + + (define/override (hide-children) + (when saved-child + (send saved-child hide-children))) + (define/override (show-children) + (when saved-child + (send saved-child show-children))) + (define/override (fixup-locations-children) + (when saved-child + (send saved-child fixup-locations-children))) + + (define/override (children-accept-drag on?) + (when saved-child + (send saved-child child-accept-drag on?))) + + (define/override (enable-window on?) + (when saved-child + (send saved-child enable-window (and on? (is-window-enabled?))))) + + (define/override (is-shown?) + (tell #:type _bool cocoa isVisible)) + + (define/override (is-shown-to-root?) + (is-shown?)) + + (define/override (is-shown-to-before-root?) #t) + + (define/override (is-parent-enabled-to-root?) + #t) + + (define/override (is-view?) #f) + + (define is-main? #f) + (define first-responder #f) + + (define saved-child #f) + (define/override (register-child child on?) + (unless on? (error 'register-child-in-frame "did not expect #f")) + (unless (or (not saved-child) (eq? child saved-child)) + (error 'register-child-in-frame "expected only one child")) + (set! saved-child child) + (on-new-child child #t)) + + (define/override (set-cursor c) + (when saved-child + (send saved-child set-cursor c))) + + (define/public (notify-responder on?) + (set! is-main? on?) + (when first-responder + (do-notify-responder first-responder on?))) + + (define/private (do-notify-responder wx on?) + (send wx focus-is-on on?) + (queue-window-event wx + (if on? + (lambda () (send wx on-set-focus)) + (lambda () (send wx on-kill-focus))))) + + (define/override (is-responder wx on?) + (unless (and (not on?) + (not (eq? first-responder wx))) + (if on? + (set! first-responder wx) + (set! first-responder #f)) + (when is-main? + (do-notify-responder wx on?)))) + + (define/public (install-wait-cursor) + (when (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tellv (get-wait-cursor-handle) set))) + + (define/public (uninstall-wait-cursor) + (when (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tellv arrow-cursor-handle set))) + + (define/public (set-wait-cursor-mode on?) + (if on? + (tell cocoa disableCursorRects) + (tell cocoa enableCursorRects)) + (when (eq? this front) + (if on? + (install-wait-cursor) + (uninstall-wait-cursor)))) + + (define/override (start-no-cursor-rects) + (tell cocoa disableCursorRects)) + + (define/override (end-no-cursor-rects) + (unless (positive? (eventspace-wait-cursor-count (get-eventspace))) + (tell cocoa enableCursorRects))) + + (define/public (flip-screen y) + (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) + (- (NSSize-height (NSRect-size f)) y))) + + (define/override (flip y h) (flip-screen (+ y h))) + + (define/override (get-y) + (- (super get-y) (if caption? 22 0))) + + (define/override (set-size x y w h) + (unless (and (= x -1) (= y -1)) + (internal-move x y)) + (let ([f (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect + (make-NSPoint (if (and is-a-dialog? + (let ([p (get-parent)]) + (and p + (eq? this (send p get-sheet))))) + ;; need to re-center sheet: + (let* ([p (get-parent)] + [px (send p get-x)] + [pw (send p get-width)]) + (+ px (/ (- pw w) 2))) + ;; keep current x position: + (NSPoint-x (NSRect-origin f))) + ;; keep current y position: + (- (NSPoint-y (NSRect-origin f)) + (- h + (NSSize-height (NSRect-size f))))) + (make-NSSize w h)) + display: #:type _BOOL #t))) + (define/override (internal-move x y) + (let ([x (if (= x -11111) (get-x) x)] + [y (if (= y -11111) (get-y) y)]) + (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (- (flip-screen y) + (get-menu-bar-height)))))) + + (define/override (center dir wrt) + (let ([f (tell #:type _NSRect cocoa frame)] + [s (tell #:type _NSRect (tell cocoa screen) frame)]) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect (make-NSPoint + (if (or (eq? dir 'both) + (eq? dir 'horizontal)) + (quotient (- (NSSize-width (NSRect-size s)) + (NSSize-width (NSRect-size f))) + 2) + (NSPoint-x (NSRect-origin f))) + (if (or (eq? dir 'both) + (eq? dir 'vertical)) + (quotient (- (NSSize-height (NSRect-size s)) + (NSSize-height (NSRect-size f))) + 2) + (NSPoint-x (NSRect-origin f)))) + (NSRect-size f)) + display: #:type _BOOL #t))) + + (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) + (define (adj v) (if (negative? v) 32000 v)) + (tellv cocoa setMinSize: #:type _NSSize (make-NSSize (max min-x 1) + (max min-y 1))) + (tellv cocoa setMaxSize: #:type _NSSize (make-NSSize (adj max-x) + (adj max-y))) + (tellv cocoa setResizeIncrements: #:type _NSSize (make-NSSize inc-x inc-y))) + + (define hide-mb? (and (memq 'hide-menu-bar style) #t)) + (define mb #f) + (define/public (get-menu-bar) mb) + (define/public (set-menu-bar _mb) + (set! mb _mb) + (send mb set-top-window this) + (when (tell #:type _BOOL cocoa isMainWindow) + (install-mb))) + + (define/public (install-mb) + (tellv NSMenu setMenuBarVisible: #:type _BOOL (not hide-mb?)) + (if mb + (send mb install) + (send empty-mb install))) + + (define/public (on-activate on?) (void)) + + (define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (define/public (on-menu-click) (void)) + + (define/public (on-toolbar-click) (void)) + (define/public (on-menu-command c) (void)) + (def/public-unimplemented on-mdi-activate) + (define/public (on-close) #t) + (define/public (designate-root-frame) + (set! root-fake-frame this)) + (def/public-unimplemented system-menu) + + (define/public (set-modified on?) + (let ([b (tell cocoa standardWindowButton: #:type _NSInteger NSWindowCloseButton)]) + (tellv b setDocumentEdited: #:type _BOOL on?))) + + (define/public (is-maximized?) + (tell #:type _BOOL cocoa isZoomed)) + (define/public (maximize on?) + (unless (eq? (tell #:type _BOOL cocoa isZoomed) + (and on? #t)) + (tellv cocoa zoom: cocoa))) + + (define/public (iconized?) + (tell #:type _BOOL cocoa isMiniaturized)) + (define/public (iconize on?) + (if on? + (tellv cocoa miniaturize: cocoa) + (tellv cocoa deminiaturize: cocoa))) + + (define/public (set-title s) + (tellv cocoa setTitle: #:type _NSString s)) + + + (define color-callback void) + (define/public (set-color-callback cb) + (set! color-callback cb)) + (define/override (on-color-change) + (queue-window-event this (lambda () (color-callback)))))) + +;; ---------------------------------------- + +(define (location->window x y) + (let ([n (tell #:type _NSInteger NSWindow + windowNumberAtPoint: #:type _NSPoint + (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) + belowWindowWithWindowNumber: #:type _NSInteger 0)]) + (atomically (let ([b (hash-ref all-windows n #f)]) + (and b (weak-box-value b)))))) + +(set-fixup-window-locations! + (lambda () + ;; in atomic mode + (for ([b (in-hash-values all-windows)]) + (let ([f (weak-box-value b)]) + (when f + (send f fixup-locations-children)))))) + diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt new file mode 100644 index 00000000..153b821b --- /dev/null +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require racket/class + ffi/unsafe + racket/math + ffi/unsafe/objc + "../../syntax.rkt" + "item.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt") + +(provide + (protect-out gauge%)) + +;; ---------------------------------------- + +(import-class NSProgressIndicator) + +(define-objc-class MyProgressIndicator NSProgressIndicator + #:mixins (KeyMouseResponder CursorDisplayer) + [wxb]) + +(defclass gauge% item% + (init parent + label + rng + x y w h + style + font) + (inherit get-cocoa) + + (super-new [parent parent] + [cocoa (let ([cocoa (as-objc-allocation + ;; Beware that a guage may be finally deallocated in + ;; a seperate OS-level thread + (tell (tell MyProgressIndicator alloc) init))]) + (tellv cocoa setIndeterminate: #:type _BOOL #f) + (tellv cocoa setMaxValue: #:type _double* rng) + (tellv cocoa setDoubleValue: #:type _double* 0.0) + (tellv cocoa sizeToFit) + (when (memq 'vertical style) + (let ([r (tell #:type _NSRect cocoa frame)]) + (printf "height ~s\n" (NSSize-height (NSRect-size r))) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect + (NSRect-origin r) + (make-NSSize + (NSSize-height (NSRect-size r)) + (NSSize-width (NSRect-size r))))) + (tellv cocoa rotateByAngle: #:type _CGFloat -90))) + cocoa)] + [callback void] + [no-show? (memq 'deleted style)]) + + (define cocoa (get-cocoa)) + + (define/override (enable on?) (void)) + (define/override (is-window-enabled?) #t) + + (define/public (get-range) + (inexact->exact (floor (tell #:type _double cocoa maxValue)))) + (define/public (set-range rng) + (tellv cocoa setMaxValue: #:type _double* rng) + (tellv cocoa setDoubleValue: #:type _double* (min rng (tell #:type _double cocoa doubleValue)))) + + (define/public (set-value v) + (tellv cocoa setDoubleValue: #:type _double* v)) + (define/public (get-value) + (min (inexact->exact (floor (tell #:type _double cocoa doubleValue))) + (get-range)))) diff --git a/collects/mred/private/wx/cocoa/gc.rkt b/collects/mred/private/wx/cocoa/gc.rkt new file mode 100644 index 00000000..8e384f37 --- /dev/null +++ b/collects/mred/private/wx/cocoa/gc.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt") + +(provide + (protect-out scheme_add_gc_callback + scheme_remove_gc_callback + make-gc-action-desc)) + +(define objc-lib (ffi-lib "libobjc")) + +(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer)) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define (make-gc-action-desc win sel val) + (vector + (vector (if (= (ctype-sizeof _CGFloat) 4) + 'ptr_ptr_float->void + 'ptr_ptr_double->void) + msg-send-proc + win + sel + val))) diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt new file mode 100644 index 00000000..17561714 --- /dev/null +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "panel.rkt") + +(provide + (protect-out group-panel%)) + +(import-class NSBox) + +(define-objc-class MyBox NSBox + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb]) + +(defclass group-panel% (panel-mixin window%) + (init parent + x y w h + style + label) + (inherit get-cocoa) + + (super-new [parent parent] + [cocoa + (let ([cocoa (as-objc-allocation + (tell (tell MyBox alloc) init))]) + (when label + (tellv cocoa setTitle: #:type _NSString label) + (tellv cocoa sizeToFit)) + cocoa)] + [no-show? (memq 'deleted style)]) + + (define/override (get-cocoa-content) + (tell (get-cocoa) contentView)) + (define/override (get-cocoa-cursor-content) + (get-cocoa)) + + (define/public (set-label l) + (tellv (get-cocoa) setTitle: #:type _NSString l))) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt new file mode 100644 index 00000000..ac05763a --- /dev/null +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -0,0 +1,137 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + racket/class + racket/draw/unsafe/cairo + racket/draw/private/local + racket/draw/unsafe/bstr + "utils.rkt" + "types.rkt" + "const.rkt" + "cg.rkt" + "bitmap.rkt" + "../../lock.rkt" + (only-in '#%foreign ffi-callback)) + +(provide + (protect-out bitmap->image + image->bitmap)) + +(import-class NSImage NSGraphicsContext) + +(define NSCompositeCopy 1) + +(define _CGImageRef (_cpointer 'CGImageRef)) +(define _CGColorSpaceRef (_cpointer 'CGColorSpaceRef)) +(define _CGDataProviderRef (_cpointer 'GCDataProviderRef)) + +(define _CGRect _NSRect) + +(define _size_t _long) +(define _off_t _long) + +(define-appserv CGColorSpaceCreateDeviceRGB (_fun -> _CGColorSpaceRef)) +(define-appserv CGColorSpaceRelease (_fun _CGColorSpaceRef -> _void)) + +(define-appserv CGImageCreate (_fun _size_t ; w + _size_t ; h + _size_t ; bitsPerComponent + _size_t ; bitsPerPixel + _size_t ; bytesPerRow + _CGColorSpaceRef ; colorspace + _int ; bitmapInfo + _CGDataProviderRef ; provider + _pointer ; CGFloat decode[] + _bool ; shouldInterpolate + _int ; intent + -> _CGImageRef)) + +(define-appserv CGContextDrawImage (_fun _CGContextRef _CGRect _CGImageRef -> _void)) + +(define free-it + (ffi-callback free (list _pointer) _void #f #t)) + +(define-appserv CGDataProviderCreateWithData (_fun _pointer _pointer _size_t _fpointer + -> _CGDataProviderRef)) +(define-appserv CGDataProviderRelease (_fun _CGDataProviderRef -> _void)) + +(define (get-image-bytes info) + info) +(define (release-image-bytes info bytes) + (void)) +(define (get-bytes-at-position bytes dest-bytes start count) + (memcpy dest-bytes (ptr-add bytes start) count)) +(define (release-info info) + (free info)) + +(define (bitmap->image bm) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [str (make-bytes (* w h 4) 255)]) + (send bm get-argb-pixels 0 0 w h str #f) + (let ([mask (send bm get-loaded-mask)]) + (when mask + (send mask get-argb-pixels 0 0 w h str #t))) + (atomically + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) + (memcpy rgba str (sub1 (* w h 4))) + (let* ([cs (CGColorSpaceCreateDeviceRGB)] + [provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)] + [image (CGImageCreate w + h + 8 + 32 + (* 4 w) + cs + (bitwise-ior kCGImageAlphaFirst + kCGBitmapByteOrder32Big) + provider ; frees `rgba' + #f + #f + 0)]) + (CGDataProviderRelease provider) + (CGColorSpaceRelease cs) + ;; This works on 10.6 and later: + #; + (as-objc-allocation + (tell (tell NSImage alloc) + initWithCGImage: #:type _CGImageRef image + size: #:type _NSSize (make-NSSize w h))) + ;; To work with older versions: + (let* ([size (make-NSSize w h)] + [i (as-objc-allocation + (tell (tell NSImage alloc) + initWithSize: #:type _NSSize size))]) + (tellv i lockFocus) + (CGContextDrawImage + (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort) + (make-NSRect (make-NSPoint 0 0) size) + image) + (tellv i unlockFocus) + i)))))) + +(define (image->bitmap i) + (let* ([s (tell #:type _NSSize i size)] + [w (NSSize-width s)] + [h (NSSize-height s)] + [bm (make-object quartz-bitmap% + (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))] + [surface (let ([s (send bm get-cairo-surface)]) + (cairo_surface_flush s) + s)] + [cg (cairo_quartz_surface_get_cg_context surface)] + [gc (tell NSGraphicsContext + graphicsContextWithGraphicsPort: #:type _pointer cg + flipped: #:type _BOOL #f)]) + (CGContextSaveGState cg) + (CGContextTranslateCTM cg 0 h) + (CGContextScaleCTM cg 1 -1) + (tellv NSGraphicsContext saveGraphicsState) + (tellv NSGraphicsContext setCurrentContext: gc) + (let ([r (make-NSRect (make-NSPoint 0 0) (make-NSSize w h))]) + (tellv i drawInRect: #:type _NSRect r fromRect: #:type _NSRect r + operation: #:type _int NSCompositeCopy fraction: #:type _CGFloat 1.0)) + (tellv NSGraphicsContext restoreGraphicsState) + (CGContextRestoreGState cg) + bm)) diff --git a/collects/mred/private/wx/cocoa/init.rkt b/collects/mred/private/wx/cocoa/init.rkt new file mode 100644 index 00000000..4764cc1f --- /dev/null +++ b/collects/mred/private/wx/cocoa/init.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "pool.rkt" + "queue.rkt") + +(define pump-thread (cocoa-start-event-pump)) +(cocoa-install-event-wakeup) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt new file mode 100644 index 00000000..2ff73fa1 --- /dev/null +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "../../lock.rkt" + "window.rkt" + "const.rkt" + "types.rkt" + "font.rkt") + +(provide + (protect-out item% + install-control-font + sys-font-size)) + +(import-class NSFont) + +(define sys-font-size 13) +(define sys-font + (atomically + (let ([f (tell NSFont systemFontOfSize: #:type _CGFloat sys-font-size)]) + (tellv f retain) + f))) + +(define (install-control-font cocoa font) + (if font + (tellv cocoa setFont: (font->NSFont font)) + (tellv cocoa setFont: sys-font))) + +(defclass item% window% + (inherit get-cocoa + is-window-enabled?) + + (init-field callback) + + (define/public (get-cocoa-control) (get-cocoa)) + + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?))) + + (define/override (gets-focus?) + (tell #:type _BOOL (get-cocoa-control) canBecomeKeyView)) + + (define/public (command e) + (callback this e)) + + (def/public-unimplemented set-label) + (def/public-unimplemented get-label) + (super-new) + + (define/public (init-font cocoa font) + (install-control-font cocoa font))) diff --git a/collects/mred/private/wx/cocoa/keycode.rkt b/collects/mred/private/wx/cocoa/keycode.rkt new file mode 100644 index 00000000..7eb4d26f --- /dev/null +++ b/collects/mred/private/wx/cocoa/keycode.rkt @@ -0,0 +1,56 @@ +#lang racket/base + +(provide map-key-code) + +(define (map-key-code v) + (hash-ref + #hash((122 . f1) + (120 . f2) + (99 . f3) + (118 . f4) + (96 . f5) + (97 . f6) + (98 . f7) + (100 . f8) + (101 . f9) + (109 . f10) + (103 . f11) + (111 . f12) + (105 . f13) + (107 . f14) + (113 . f15) + (#x35 . escape) + (#x7e . up) + (#x7d . down) + (#x3d . down) + (#x7b . left) + (#x3b . left) + (#x7c . right) + (#x3c . right) + (#x24 . #\return) + (#x30 . #\tab) + (#x33 . #\backspace) + (#x75 . #\rubout) + (#x73 . home) + (#x77 . end) + (#x74 . prior) + (#x79 . next) + (#x45 . add) + (78 . subtract) + (#x43 . multiply) + (#x4b . divide) + (71 . separator) + (65 . decimal) + (76 . #\u3) ; numpad enter + (82 . numpad0) + (83 . numpad1) + (84 . numpad2) + (85 . numpad3) + (86 . numpad4) + (87 . numpad5) + (88 . numpad6) + (89 . numpad7) + (91 . numpad8) + (92 . numpad9)) + v + #f)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt new file mode 100644 index 00000000..0c8828ba --- /dev/null +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -0,0 +1,215 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + (only-in scheme/list take drop) + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "window.rkt" + "font.rkt" + "../common/event.rkt") + +(provide + (protect-out list-box%)) + +;; ---------------------------------------- + +(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet) +(import-protocol NSTableViewDataSource) + +(define-objc-class MyTableView NSTableView + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) + (let ([wx (->wx wxb)]) + (tell + (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString + (if wx (send wx get-row row) "???"))] + [font (and wx (send wx get-cell-font))]) + (when font + (tellv c setFont: font)) + c) + autorelease))] + [-a _void (doubleClicked: [_id sender]) + (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] + [-a _void (tableViewSelectionDidChange: [_id aNotification]) + (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))]) + +(define-objc-class MyDataSource NSObject + #:protocols (NSTableViewDataSource) + [wxb] + [-a _NSInteger (numberOfRowsInTableView: [_id view]) + (let ([wx (->wx wxb)]) + (send wx number))] + [-a _NSString (tableView: [_id aTableView] + objectValueForTableColumn: [_id aTableColumn] + row: [_NSInteger rowIndex]) + (let ([wx (->wx wxb)]) + (if wx + (send wx get-row rowIndex) + "???"))]) + +(define (remove-nth data i) + (cond + [(zero? i) (cdr data)] + [else (cons (car data) (remove-nth (cdr data) (sub1 i)))])) + +(defclass list-box% item% + (init parent cb + label kind x y w h + choices style + font label-font) + (inherit set-size init-font + register-as-child) + + (define source (as-objc-allocation + (tell (tell MyDataSource alloc) init))) + (set-ivar! source wxb (->wxb this)) + + (define items choices) + (define data (map (lambda (x) (box #f)) choices)) + (define count (length choices)) + + (define cocoa (as-objc-allocation + (tell (tell NSScrollView alloc) init))) + (define content-cocoa (let ([content-cocoa + (as-objc-allocation + (tell (tell MyTableView alloc) init))]) + (tellv content-cocoa setDelegate: content-cocoa) + (tellv content-cocoa setDataSource: source) + (tellv content-cocoa addTableColumn: + (as-objc-allocation + (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))) + (init-font content-cocoa font) + content-cocoa)) + (set-ivar! content-cocoa wxb (->wxb this)) + + (tellv cocoa setDocumentView: content-cocoa) + (tellv cocoa setHasVerticalScroller: #:type _BOOL #t) + (tellv content-cocoa setHeaderView: #f) + (define allow-multi? (not (eq? kind 'single))) + (when allow-multi? + (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t)) + + (define/override (get-cocoa-content) content-cocoa) + (define/override (get-cocoa-control) content-cocoa) + + (super-new [parent parent] + [cocoa cocoa] + [no-show? (memq 'deleted style)] + [callback cb]) + + (set-size 0 0 32 50) + ; (tellv content-cocoa sizeToFit) + + (tellv content-cocoa setTarget: content-cocoa) + (tellv content-cocoa setDoubleAction: #:type _SEL (selector doubleClicked:)) + + (def/public-unimplemented get-label-font) + + (define cell-font (and font (font->NSFont font))) + (define/public (get-cell-font) + cell-font) + + (define/public (get-selection) + (if allow-multi? + (let ([l (get-selections)]) + (if (null? l) + -1 + (car l))) + (tell #:type _NSInteger content-cocoa selectedRow))) + (define/public (get-selections) + (atomically + (with-autorelease + (let ([v (tell content-cocoa selectedRowIndexes)]) + (begin0 + (let loop ([i (tell #:type _NSInteger v firstIndex)]) + (cond + [(= i NSNotFound) null] + [else (cons i (loop (tell #:type _NSInteger v + indexGreaterThanIndex: #:type _NSInteger i)))]))))))) + + (define/private (visible-range) + (tell #:type _NSRange content-cocoa + rowsInRect: #:type _NSRect (tell #:type _NSRect cocoa documentVisibleRect))) + + (define/public (get-first-item) + (NSRange-location (visible-range))) + (define/public (number-of-visible-items) + (NSRange-length (visible-range))) + (define/public (set-first-visible-item i) + ;; FIXME: visble doesn't mean at top: + (tellv content-cocoa scrollRowToVisible: #:type _NSInteger i)) + + (define/public (set-string i s) + (set! items + (append (take items i) + (list s) + (drop items (add1 i)))) + (reset)) + + (define/public (number) + ;; Can be called by event-handling thread + count) + (define/public (get-row n) + ;; Can be called by event-handling thread + (list-ref items n)) + + (define callback cb) + (define/public (clicked event-type) + (unless (zero? count) + (callback this (new control-event% + [event-type event-type] + [time-stamp (current-milliseconds)])))) + + (define/public (set-data i v) (set-box! (list-ref data i) v)) + (define/public (get-data i) (unbox (list-ref data i))) + + (define/public (selected? i) + (tell #:type _BOOL content-cocoa isRowSelected: #:type _NSInteger i)) + + (define/public (select i [on? #t] [extend? #t]) + (if on? + (atomically + (with-autorelease + (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)]) + (tellv content-cocoa + selectRowIndexes: index + byExtendingSelection: #:type _BOOL (and extend? allow-multi?))))) + (tellv content-cocoa deselectRow: #:type _NSInteger i))) + (define/public (set-selection i) + (select i #t #f)) + + (define/public (delete i) + (set! count (sub1 count)) + (set! items (remove-nth items i)) + (set! data (remove-nth data i)) + (reset)) + (define/public (clear) + (set! count 0) + (set! items null) + (set! data null) + (reset)) + (define/public (set choices) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (set! count (length choices)) + (reset)) + + (public [append* append]) + (define (append* s [v #f]) + (set! count (add1 count)) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (reset)) + + (define/public (reset) + (tellv content-cocoa noteNumberOfRowsChanged) + (tellv content-cocoa reloadData)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt new file mode 100644 index 00000000..2a3fde20 --- /dev/null +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -0,0 +1,199 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + (only-in racket/list take drop) + "../../syntax.rkt" + "../../lock.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "queue.rkt") + +(provide + (protect-out menu-bar% + get-menu-bar-height)) + +(import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) + +(define-cf CFBundleGetMainBundle (_fun -> _pointer)) +(define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id)) + +(define app-name + (or + (let ([dict (CFBundleGetInfoDictionary (CFBundleGetMainBundle))]) + (and dict + (let ([appName (tell dict objectForKey: #:type _NSString "CFBundleName")] + [alt (lambda () + (tell #:type _NSString (tell NSProcessInfo processInfo) processName))]) + (if (not appName) + (alt) + (let ([appName (cast appName _id _NSString)]) + (if (equal? appName "") + (alt) + appName)))))) + "MrEd")) + +(define the-apple-menu #f) +(define recurring-for-command (make-parameter #f)) + +(define-objc-class MyBarMenu NSMenu + [] + ;; Disable automatic handling of keyboard shortcuts, except for + ;; the Apple menu + (-a _BOOL (performKeyEquivalent: [_id evt]) + (or (and the-apple-menu + (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) + ;; Explicity send the event to the keyWindow: + (and + ;; Don't go into an infinite loop: + (not (recurring-for-command)) + ;; Don't handle Cmd-` for cycling through windows: + ;; [Is this right for all locales?] + (not (equal? "`" (tell #:type _NSString evt characters))) + ;; Otherwise, try to dispatch to the first respnder: + (let ([w (tell app keyWindow)]) + (and w + (let ([r (tell w firstResponder)]) + (and r + (begin + (parameterize ([recurring-for-command #t]) + (tell r keyDown: evt)) + #t))))))))) + +(define cocoa-mb (tell (tell MyBarMenu alloc) init)) +(define current-mb #f) + +;; Used to detect mouse click on the menu bar: +(define in-menu-bar-range + (let ([f (tell #:type _NSRect + (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0) + frame)]) + (let ([x (NSPoint-x (NSRect-origin f))] + [w (NSSize-width (NSRect-size f))] + [y (+ (NSPoint-y (NSRect-origin f)) + (NSSize-height (NSRect-size f)))]) + (lambda (p) + (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) + (and (<= x (NSPoint-x p) (+ x w)) + (<= (- y h) (NSPoint-y p) y))))))) + +(define (get-menu-bar-height) + (inexact->exact (floor (tell #:type _CGFloat cocoa-mb menuBarHeight)))) + +(set-menu-bar-hooks! in-menu-bar-range) + +;; Init menu bar +(let ([app (tell NSApplication sharedApplication)] + [add-one (lambda (mb menu) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString "" + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (tellv item setSubmenu: menu) + (tellv mb addItem: item) + (tellv item release)))]) + (let ([apple (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "")]) + (let ([std (lambda (title sel [shortcut ""] [mods #f] [delegate? #f]) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString title + action: #:type _SEL sel + keyEquivalent: #:type _NSString shortcut)]) + (when mods + (tellv item setKeyEquivalentModifierMask: #:type _NSInteger mods)) + (tellv item setTarget: (if delegate? + (tell app delegate) + app)) + (tellv apple addItem: item) + (tellv item release)))]) + (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) + (std "Preferences..." (selector openPreferences:) "," #f #t) + (tellv apple addItem: (tell NSMenuItem separatorItem)) + (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) + (tellv app setServicesMenu: services) + (let ([item (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString "Services" + action: #:type _SEL #f + keyEquivalent: #:type _NSString "")]) + (tellv item setSubmenu: services) + (tellv apple addItem: item) + (tellv item release))) + (tellv apple addItem: (tell NSMenuItem separatorItem)) + (std (format "Hide ~a" app-name) (selector hide:) "h") + (std "Hide Others" (selector hideOtherApplications:) "h" (bitwise-ior + NSAlternateKeyMask + NSCommandKeyMask)) + (std "Show All" (selector unhideAllApplications:)) + (tellv apple addItem: (tell NSMenuItem separatorItem)) + (std (format "Quit ~a" app-name) (selector terminate:) "q")) + (add-one cocoa-mb apple) + (tellv app setAppleMenu: apple) + (tellv apple release) + (tellv app setMainMenu: cocoa-mb) + (set! the-apple-menu apple))) + +(tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f) + +(defclass menu-bar% object% + (define menus null) + + (define/public (enable-top pos on?) + (set-box! (cddr (list-ref menus pos)) on?) + (when (eq? current-mb this) + (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)) + setEnabled: #:type _BOOL on?))) + + (define/public (delete which pos) + (atomically + (when (eq? current-mb this) + (tellv cocoa-mb removeItem: + (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)))) + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + (sub1 pos)))]))))) + + (public [append-menu append]) + (define (append-menu menu title) + (set! menus (append menus (list (list* menu title (box #t))))) + (send menu set-parent this) + (when (eq? current-mb this) + (send menu install cocoa-mb title #t))) + + (define/public (install) + (let loop () + (when ((tell #:type _NSInteger cocoa-mb numberOfItems) . > . 1) + (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) + (loop))) + (for-each (lambda (menu) + (send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu)))) + menus) + (set! current-mb this)) + + (define top-wx #f) + (define/public (set-top-window top) + (set! top-wx top)) + (define/public (get-top-window) + top-wx) + + (define/public (set-label-top pos str) + (set! menus (append + (take menus pos) + (let ([i (list-ref menus pos)]) + (list (cons (car i) (cons str (cddr i))))) + (drop menus (add1 pos)))) + (when (eq? current-mb this) + (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) + setTitle: #:type _NSString (clean-menu-label str)))) + + (define/public (do-on-menu-click) + (let ([es (send top-wx get-eventspace)]) + (when es + (queue-event es (lambda () + (send top-wx on-menu-click)))))) + + (super-new)) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt new file mode 100644 index 00000000..bea50304 --- /dev/null +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -0,0 +1,101 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "const.rkt") + +(provide + (protect-out menu-item% + set-menu-item-shortcut)) + +(import-class NSMenuItem) + +(define-objc-class MyMenuItem NSMenuItem + [wxb] + (-a _void (selected: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx + (send wx selected)))) + (-a _void (selectedCheckable: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx + (send wx selected-checkable self))))) + + +(defclass menu-item% object% + (define/public (id) this) + + (define parent #f) + (define/public (selected) + ;; called in Cocoa thread + (send parent item-selected this)) + (define/public (selected-checkable cocoa) + ;; called in Cocoa thread + (set! checked? (not checked?)) + (tellv cocoa setState: #:type _int (if checked? 1 0)) + (send parent item-selected this)) + + (define/public (set-parent p) + (set! parent p)) + + (define label #f) + (define/public (set-label l) (set! label l)) + (define/public (get-label) label) + + (define checked? #f) + (define/public (set-checked c?) (set! checked? c?)) + (define/public (get-checked) checked?) + + (define enabled? #t) + (define/public (set-enabled-flag e?) (set! enabled? e?)) + (define/public (get-enabled-flag) enabled?) + + (define submenu #f) + (define/public (set-submenu m) (set! submenu m)) + + (define/public (install menu checkable?) + (if submenu + (send submenu install menu label enabled?) + (let ([item (as-objc-allocation + (tell (tell MyMenuItem alloc) + initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") + action: #:type _SEL #f + keyEquivalent: #:type _NSString ""))]) + (set-ivar! item wxb (->wxb this)) + (tellv menu addItem: item) + (tellv item setEnabled: #:type _BOOL enabled?) + (when checked? + (tellv item setState: #:type _int 1)) + (tellv item setTarget: item) + (tellv item setAction: #:type _SEL (if checkable? + (selector selectedCheckable:) + (selector selected:))) + (set-menu-item-shortcut item label) + (release item)))) + + (super-new)) + +(define (set-menu-item-shortcut item label) + (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) + (if shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)) + (tellv item setKeyEquivalent: #:type _NSString "")))) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt new file mode 100644 index 00000000..0162bc21 --- /dev/null +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -0,0 +1,194 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + (only-in scheme/list drop take) + "../common/event.rkt" + "../../syntax.rkt" + "../../lock.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "window.rkt" + "menu-item.rkt") + +(provide + (protect-out menu%)) + +(import-class NSMenu NSMenuItem NSEvent) + +(define-struct mitem (item checkable?)) + +(defclass menu% object% + (init-field label + callback + font) + + (super-new) + + (define items null) + + (define cocoa #f) + (define cocoa-menu #f) + + (define/public (create-menu label) + (unless cocoa + (set! cocoa + (as-objc-allocation + (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString (clean-menu-label label) + action: #:type _SEL #f + keyEquivalent: #:type _NSString ""))) + (set! cocoa-menu + (as-objc-allocation + (tell (tell NSMenu alloc) + initWithTitle: #:type _NSString (clean-menu-label label)))) + (tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f) + (tellv cocoa setSubmenu: cocoa-menu) + (for-each (lambda (item) + (if item + (send (mitem-item item) install cocoa-menu (mitem-checkable? item)) + (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) + items))) + + (define/public (install cocoa-parent label enabled?) + (create-menu label) + (tellv cocoa-parent addItem: cocoa) + (tellv cocoa setEnabled: #:type _BOOL enabled?)) + + (define popup-box #f) + + (define/public (do-popup v win x y queue-cb) + (unless (null? items) + (create-menu "menu") + (let ([b (box #f)]) + (set! popup-box b) + (if (not (version-10.6-or-later?)) + ;; For 10.5 and earlier: + (let ([p (tell #:type _NSPoint v + convertPoint: #:type _NSPoint (make-NSPoint x y) + toView: #f)]) + (atomically + (with-autorelease + (tellv NSMenu popUpContextMenu: cocoa-menu + withEvent: (tell NSEvent + mouseEventWithType: #:type _int NSLeftMouseDown + location: #:type _NSPoint p + modifierFlags: #:type _NSUInteger 0 + timestamp: #:type _double 0.0 + windowNumber: #:type _NSUInteger + (tell #:type _NSInteger win windowNumber) + context: #:type _pointer #f + eventNumber: #:type _NSInteger 0 + clickCount: #:type _NSInteger 1 + pressure: #:type _float 1.0) + forView: v)))) + ;; 10.6 and later: + (tellv cocoa-menu + popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0) + atLocation: #:type _NSPoint (make-NSPoint x y) + inView: v)) + (set! popup-box #f) + (let* ([i (unbox b)] + [e (new popup-event% [event-type 'menu-popdown])]) + (send e set-menu-id i) + (queue-cb (lambda () (callback this e))))))) + + (define/public (item-selected menu-item) + ;; called in Cocoa thread + (cond + [popup-box + (set-box! popup-box menu-item)] + [(parent . is-a? . menu%) + (send parent item-selected menu-item)] + [else + (let ([top (get-top-parent)]) + (when top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))))])) + + (define parent #f) + (define/public (set-parent p) (set! parent p)) + (define/public (get-top-parent) + ;; called in Cocoa thread + (and parent + (if (parent . is-a? . menu%) + (send parent get-top-parent) + (send parent get-top-window)))) + + (public [append-item append]) + (define (append-item i label help-str-or-submenu chckable?) + (send i set-label label) + (when (help-str-or-submenu . is-a? . menu%) + (send i set-submenu help-str-or-submenu) + (send help-str-or-submenu set-parent this)) + (set! items (append items (list (make-mitem i chckable?)))) + (send i set-parent this) + (when cocoa-menu + (send i install cocoa-menu chckable?))) + + (define/public (append-separator) + (set! items (append items (list #f))) + (when cocoa-menu + (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) + + (def/public-unimplemented select) + (def/public-unimplemented get-font) + (def/public-unimplemented set-width) + (def/public-unimplemented set-title) + + (define/public (set-help-string m s) (void)) + + (def/public-unimplemented number) + + (define/private (find-pos item) + (for/or ([i (in-list items)] + [pos (in-naturals)]) + (and i + (eq? (mitem-item i) item) + pos))) + + (define/public (adjust item cocoa-cb cb) + (let ([pos (find-pos item)]) + (when pos + (when cocoa-menu + (cocoa-cb (tell cocoa-menu itemAtIndex: #:type _NSInteger pos))) + (cb (list-ref items pos))))) + + (define/public (set-label item label) + (adjust item + (lambda (item-cocoa) + (tellv item-cocoa setTitle: #:type _NSString (clean-menu-label (regexp-replace #rx"\t.*" label ""))) + (set-menu-item-shortcut item-cocoa label)) + (lambda (mitem) + (send (mitem-item mitem) set-label (clean-menu-label label))))) + + (define/public (check item on?) + (adjust item + (lambda (item-cocoa) + (tellv item-cocoa setState: #:type _int (if on? 1 0))) + (lambda (mitem) + (send (mitem-item mitem) set-checked (and on? #t))))) + + (define/public (enable item on?) + (adjust item + (lambda (item-cocoa) + (tellv item-cocoa setEnabled: #:type _BOOL on?)) + (lambda (mitem) + (send (mitem-item mitem) set-enabled-flag (and on? #t))))) + + (define/public (checked? item) + (send item get-checked)) + + (define/public (delete-by-position pos) + (let ([mitem (list-ref items pos)]) + (set! items (append (take items pos) + (drop items (add1 pos)))) + (when cocoa-menu + (tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos)))) + + (define/public (delete item) + (let ([pos (find-pos item)]) + (when pos + (delete-by-position pos))))) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt new file mode 100644 index 00000000..d8f0bdc0 --- /dev/null +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -0,0 +1,130 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + racket/draw/private/bitmap + "../../syntax.rkt" + "../../lock.rkt" + "window.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "image.rkt") + +(provide + (protect-out message%)) + +;; ---------------------------------------- + +(import-class NSTextField NSImageView NSWorkspace) + +(define _OSType _uint32) + +(define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id)) + +(define (get-app-icon) + (tell (tell NSWorkspace sharedWorkspace) + iconForFile: + (tell (tell (tell NSWorkspace sharedWorkspace) + activeApplication) + objectForKey: + #:type _NSString + "NSApplicationPath"))) + +(define (make-icon label) + (let ([icon + (if (eq? label 'app) + (get-app-icon) + (let ([id (integer-bytes->integer + (case label + [(caution) #"caut"] + [(stop) #"stop"]) + #f + #t)]) + (tell (tell NSWorkspace sharedWorkspace) + iconForFileType: + (NSFileTypeForHFSTypeCode id))))]) + (tellv icon retain) + (tellv icon setSize: #:type _NSSize (make-NSSize 64 64)) + (unless (eq? label 'app) + ;; Add badge: + (let ([app-icon (get-icon 'app)]) + (tellv icon lockFocus) + (tellv app-icon drawInRect: #:type _NSRect (make-NSRect (make-NSPoint 32 0) + (make-NSSize 32 32)) + fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize 64 64)) + operation: #:type _int 2 ; NSCompositeSourceOver + fraction: #:type _CGFloat 1.0) + (tellv icon unlockFocus))) + icon)) + +(define icons (make-hash)) +(define (get-icon label) + (or (hash-ref icons label #f) + (let ([icon (atomically (make-icon label))]) + (hash-set! icons label icon) + icon))) + +;; ---------------------------------------- + +(define-objc-class MyTextField NSTextField + #:mixins (KeyMouseResponder CursorDisplayer) + [wxb]) + +(define-objc-class MyImageView NSImageView + #:mixins (KeyMouseResponder CursorDisplayer) + [wxb]) + +(defclass message% item% + (init parent label + x y + style font) + (inherit get-cocoa init-font) + + (super-new [parent parent] + [cocoa (let* ([label (cond + [(string? label) label] + [(symbol? label) (get-icon label)] + [(send label ok?) label] + [else ""])] + [cocoa + (if (string? label) + (as-objc-allocation + (tell (tell MyTextField alloc) init)) + (as-objc-allocation + (tell (tell MyImageView alloc) init)))]) + (cond + [(string? label) + (init-font cocoa font) + (tellv cocoa setSelectable: #:type _BOOL #f) + (tellv cocoa setEditable: #:type _BOOL #f) + (tellv cocoa setBordered: #:type _BOOL #f) + (tellv cocoa setDrawsBackground: #:type _BOOL #f) + (tellv cocoa setTitleWithMnemonic: #:type _NSString label) + (tellv cocoa sizeToFit)] + [else + (tellv cocoa setImage: (if (label . is-a? . bitmap%) + (bitmap->image label) + label)) + (tellv cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (if (label . is-a? . bitmap%) + (make-NSSize (send label get-width) + (send label get-height)) + (tell #:type _NSSize label size))))]) + cocoa)] + [callback void] + [no-show? (memq 'deleted style)]) + + (define/override (set-label label) + (cond + [(string? label) + (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)] + [else + (tellv (get-cocoa) setImage: (bitmap->image label))])) + + (define/override (gets-focus?) #f) + + (def/public-unimplemented get-font)) + diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt new file mode 100644 index 00000000..85864672 --- /dev/null +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -0,0 +1,95 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt") + +(provide + (protect-out panel% + panel-mixin)) + +(import-class NSView) + +(define-objc-class MyPanelView NSView + #:mixins (KeyMouseTextResponder CursorDisplayer) + [wxb]) + +(define (panel-mixin %) + (class % + (inherit register-as-child on-new-child + is-window-enabled?) + + (define lbl-pos 'horizontal) + (define children null) + + (super-new) + + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (define/override (fix-dc) + (for ([child (in-list children)]) + (send child fix-dc))) + + (define/override (hide-children) + (for ([child (in-list children)]) + (send child hide-children))) + + (define/override (show-children) + (for ([child (in-list children)]) + (send child show-children))) + + (define/override (fixup-locations-children) + (for ([child (in-list children)]) + (send child fixup-locations-children))) + + (define/override (paint-children) + (for ([child (in-list children)]) + (send child paint-children))) + + (define/override (children-accept-drag on?) + (for ([child (in-list children)]) + (send child child-accept-drag on?))) + + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (for ([child (in-list children)]) + (send child enable-window on?)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (fix-dc)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children))) + (on-new-child child on?)))) + + (define/override (show on?) + (super show on?) + (fix-dc)) + + (define/public (set-item-cursor x y) (void)))) + +(defclass panel% (panel-mixin window%) + (init parent + x y w h + style + label) + (super-new [parent parent] + [cocoa + (as-objc-allocation + (tell (tell MyPanelView alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize (max 1 w) (max 1 h)))))] + [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt new file mode 100644 index 00000000..f5e80dad --- /dev/null +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -0,0 +1,89 @@ +#lang racket/base +(require "init.rkt" + "button.rkt" + "canvas.rkt" + "check-box.rkt" + "choice.rkt" + "clipboard.rkt" + "cursor.rkt" + "dialog.rkt" + "frame.rkt" + "gauge.rkt" + "group-panel.rkt" + "item.rkt" + "list-box.rkt" + "menu.rkt" + "menu-bar.rkt" + "menu-item.rkt" + "message.rkt" + "panel.rkt" + "printer-dc.rkt" + "radio-box.rkt" + "slider.rkt" + "tab-panel.rkt" + "window.rkt" + "procs.rkt") +(provide (protect-out platform-values)) + +(define (platform-values) + (values + button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + has-x-selection? + hide-cursor + bell + display-size + display-origin + flush-display + fill-private-color + cancel-quit + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + get-double-click-time + run-printout + file-creator-and-type + location->window + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + find-graphical-system-path + play-sound + get-panel-background + font-from-user-platform-mode + get-font-from-user + color-from-user-platform-mode + get-color-from-user + special-option-key + special-control-key + get-highlight-background-color + get-highlight-text-color + make-screen-bitmap + make-gl-bitmap + check-for-break)) diff --git a/collects/mred/private/wx/cocoa/pool.rkt b/collects/mred/private/wx/cocoa/pool.rkt new file mode 100644 index 00000000..070719d2 --- /dev/null +++ b/collects/mred/private/wx/cocoa/pool.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + ffi/unsafe/atomic + "utils.rkt" + "const.rkt" + "types.rkt") + +(provide + (protect-out queue-autorelease-flush + autorelease-flush)) + +(import-class NSAutoreleasePool) + +;; This pool manages all objects that would otherwise not +;; have a pool: +(define pool (tell (tell NSAutoreleasePool alloc) init)) + +;; We need to periodically flush the main pool, otherwise +;; object autoreleased through the pool live until the +;; end of execution: +(define (autorelease-flush) + (start-atomic) + (tellv pool drain) + (set! pool (tell (tell NSAutoreleasePool alloc) init)) + (end-atomic)) + +(define queued? #f) +(define autorelease-evt (make-semaphore)) + +(define (queue-autorelease-flush) + (start-atomic) + (unless queued? + (semaphore-post autorelease-evt) + (set! queued? #t)) + (end-atomic)) + +;; Create a thread to periodically flush: +(void + (thread (lambda () + (let loop () + (sync autorelease-evt) + (set! queued? #f) + (autorelease-flush) + (loop))))) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt new file mode 100644 index 00000000..580ad92e --- /dev/null +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -0,0 +1,208 @@ +#lang racket/base +(require racket/class + racket/math + racket/draw/private/local + racket/draw/private/dc + racket/draw/unsafe/cairo + racket/draw/private/bitmap + racket/draw/private/bitmap-dc + racket/draw/private/record-dc + racket/draw/private/ps-setup + ffi/unsafe + ffi/unsafe/objc + "../../lock.rkt" + "dc.rkt" + "frame.rkt" + "bitmap.rkt" + "cg.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out printer-dc% + show-print-setup)) + +(import-class NSPrintOperation NSView NSGraphicsContext + NSPrintInfo NSDictionary NSPageLayout + NSNumber) + +(define NSPortraitOrientation 0) +(define NSLandscapeOrientation 1) + +(define-cocoa NSPrintScalingFactor _id) + +(define-objc-class PrinterView NSView + [wxb] + [-a _BOOL (knowsPageRange: [_NSRange-pointer rng]) + (set-NSRange-location! rng 1) + (set-NSRange-length! rng (let ([wx (->wx wxb)]) + (if wx + (send wx get-page-count) + 0))) + #t] + [-a _NSRect (rectForPage: [_NSInteger n]) + (let ([wx (->wx wxb)]) + (if wx + (send wx get-rect-for-page n) + (make-NSRect (make-NSPoint 0 0) + (make-NSSize 10 10))))] + [-a _void (beginPageInRect: [_NSRect aRect] atPlacement: [_NSPoint location]) + (let ([wx (->wx wxb)]) + (when wx + (send wx start-page-at aRect))) + (super-tell #:type _void beginPageInRect: #:type _NSRect aRect atPlacement: #:type _NSPoint location)] + [-a _void (drawPageBorderWithSize: [_NSSize size]) + (let ([wx (->wx wxb)]) + (when wx + (send wx draw-print-page self size)))]) + +(define (make-print-info [prev #f]) + (as-objc-allocation-with-retain + (tell (tell NSPrintInfo alloc) + initWithDictionary: + (if prev + (tell prev dictionary) + (tell NSDictionary dictionary))))) + +(define (get-scaling-factor print-info) + ;; 10.6 only: + #; + (tell #:type _CGFloat print-info scalingFactor) + (atomically + (with-autorelease + (tell #:type _double + (tell (tell print-info dictionary) + objectForKey: NSPrintScalingFactor) + doubleValue)))) + +(define (install-pss-to-print-info pss print-info) + (tellv print-info setOrientation: #:type _int (if (eq? (send pss get-orientation) 'landscape) + NSLandscapeOrientation + NSPortraitOrientation)) + (let ([scale (let ([x (box 0)] + [y (box 0)]) + (send pss get-scaling x y) + (unbox y))]) + ;; 10.6 only: + #; + (tellv print-info setScalingFactor: #:type _CGFloat scale) + (atomically + (with-autorelease + (tellv (tell print-info dictionary) + setObject: (tell NSNumber numberWithDouble: #:type _double scale) + forKey: NSPrintScalingFactor))))) + +(define NSOkButton 1) + +(define (show-print-setup parent) + (let* ([pss (current-ps-setup)] + [print-info (let ([pi (send pss get-native)]) + (or pi + (let ([pi (make-print-info)]) + (send pss set-native pi make-print-info) + pi)))]) + (install-pss-to-print-info pss print-info) + (if (atomically + (let ([front (get-front)]) + (begin0 + (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + NSOkButton) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))) + (begin + (let ([o (tell #:type _int print-info orientation)]) + (send pss set-orientation (if (= o NSLandscapeOrientation) + 'landscape + 'portrait))) + (let ([s (get-scaling-factor print-info)]) + (send pss set-scaling s s)) + #t) + #f))) + +(define printer-dc% + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object quartz-bitmap% 1 1)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define print-info (or (let-values ([(pi copier) + (send (current-ps-setup) + get-native-copy)]) + pi) + (make-print-info))) + + (install-pss-to-print-info (current-ps-setup) print-info) + + (define-values (page-width page-height page-scaling) + (let ([s (NSRect-size (tell #:type _NSRect print-info imageablePageBounds))] + [scaling (get-scaling-factor print-info)]) + (values (NSSize-width s) + (NSSize-height s) + scaling))) + + (define/override (get-size) + (values (/ page-width page-scaling) (/ page-height page-scaling))) + + (define current-page 0) + + (define/public (get-page-count) (length pages)) + (define/public (get-rect-for-page i) + (make-NSRect (make-NSPoint 0 (* (sub1 i) page-height)) + (make-NSSize page-width page-height))) + (define/public (start-page-at r) + (set! current-page (inexact->exact (round (/ (NSPoint-y (NSRect-origin r)) page-height))))) + (define/public (draw-print-page view-cocoa s) + (let ([f (tell #:type _NSRect view-cocoa frame)]) + (tellv view-cocoa lockFocus) + + (let ([cg (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort)] + [s (tell #:type _NSSize print-info paperSize)] + [b (tell #:type _NSRect print-info imageablePageBounds)]) + (CGContextTranslateCTM cg 0 (/ (NSSize-height s) page-scaling)) + (CGContextScaleCTM cg 1 -1) + (CGContextTranslateCTM cg + (/ (NSPoint-x (NSRect-origin b)) page-scaling) + (/ (- (NSSize-height s) + (+ (NSPoint-y (NSRect-origin b)) + (NSSize-height (NSRect-size b)))) + page-scaling)) + (let* ([surface (cairo_quartz_surface_create_for_cg_context cg + (inexact->exact (ceiling page-width)) + (inexact->exact (ceiling page-height)))] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([dc (make-object (dc-mixin + (class default-dc-backend% + (define/override (get-cr) cr) + (super-new))))]) + (let ([proc (list-ref (reverse pages) current-page)]) + (proc dc))) + (cairo_destroy cr))) + + (tellv view-cocoa unlockFocus))) + + (define/override (end-doc) + (define view-cocoa (as-objc-allocation-with-retain + (tell (tell PrinterView alloc) + initWithFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize 10 10))))) + (define op-cocoa (as-objc-allocation-with-retain + (tell NSPrintOperation printOperationWithView: view-cocoa + printInfo: print-info))) + + (set-ivar! view-cocoa wxb (->wxb this)) + + (atomically + (let ([front (get-front)]) + (tellv op-cocoa runOperation) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt new file mode 100644 index 00000000..a6caa393 --- /dev/null +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -0,0 +1,157 @@ +#lang racket/base +(require "../../syntax.rkt" + racket/class + racket/draw + ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt" + "frame.rkt" + "window.rkt" + "finfo.rkt" ; file-creator-and-type + "filedialog.rkt" + "colordialog.rkt" + "dc.rkt" + "bitmap.rkt" + "printer-dc.rkt" + "../common/printer.rkt" + "menu-bar.rkt" + "agl.rkt" + "sound.rkt" + "../../lock.rkt" + "../common/handlers.rkt" + (except-in "../common/default-procs.rkt" + special-control-key + special-option-key + file-creator-and-type)) + + +(provide + (protect-out + color-from-user-platform-mode + font-from-user-platform-mode + get-font-from-user + find-graphical-system-path + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + run-printout + get-double-click-time + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + cancel-quit + display-origin + display-size + bell + hide-cursor + get-display-depth + is-color-display? + id-to-menu-item + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color + check-for-break) + make-screen-bitmap + make-gl-bitmap + show-print-setup + get-color-from-user + get-panel-background + fill-private-color + flush-display + play-sound + file-creator-and-type + file-selector) + +(import-class NSScreen NSCursor) + +(define (find-graphical-system-path what) + #f) + +(define (color-from-user-platform-mode) "Show Picker") + +(define-unimplemented get-font-from-user) +(define (font-from-user-platform-mode) #f) + +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) +(define (shortcut-visible-in-label? [x #f]) #f) + +(define run-printout (make-run-printout printer-dc%)) + +(define (get-double-click-time) + 500) +(define (get-control-font-face) "Lucida Grande") +(define (get-control-font-size) 13) +(define (get-control-font-size-in-pixels?) #f) +(define (cancel-quit) (void)) + +(define (check-for-break) #f) + +(define (display-origin xb yb all?) + (if all? + (atomically + (with-autorelease + (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] + [f (tell #:type _NSRect screen visibleFrame)]) + (set-box! xb (->long (NSPoint-x (NSRect-origin f))))))) + (set-box! xb 0)) + (set-box! yb (get-menu-bar-height))) + +(define (display-size xb yb all?) + (atomically + (with-autorelease + (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] + [f (if all? + (tell #:type _NSRect screen frame) + (tell #:type _NSRect screen visibleFrame))]) + (set-box! xb (->long (NSSize-width (NSRect-size f)))) + (set-box! yb (->long (NSSize-height (NSRect-size f)))))))) + +(define-appkit NSBeep (_fun -> _void)) +(define (bell) (NSBeep)) + +(define (hide-cursor) + (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t)) + +(define (get-display-depth) 32) +(define (is-color-display?) #t) +(define (id-to-menu-item id) id) +(define (can-show-print-setup?) #t) + +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (make-object quartz-bitmap% w h)) + +(define/top (make-gl-bitmap [exact-positive-integer? w] + [exact-positive-integer? h] + [gl-config% c]) + (create-gl-bitmap w h c)) + +;; ------------------------------------------------------------ +;; Text & highlight color + +(import-class NSColor) + +(define-cocoa NSDeviceRGBColorSpace _id) + +(define (get-highlight-background-color) + (let ([hi (as-objc-allocation-with-retain + (tell (tell NSColor selectedTextBackgroundColor) + colorUsingColorSpaceName: NSDeviceRGBColorSpace))] + [as-color (lambda (v) + (inexact->exact (floor (* 255.0 v))))]) + (begin0 + (make-object color% + (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent))) + (release hi)))) + +(define (get-highlight-text-color) + #f) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt new file mode 100644 index 00000000..a66bf5d9 --- /dev/null +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -0,0 +1,394 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + racket/draw/private/dc + "pool.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "../common/queue.rkt" + "../common/handlers.rkt" + "../../lock.rkt" + "../common/freeze.rkt") + +(provide + (protect-out app + cocoa-start-event-pump + cocoa-install-event-wakeup + set-eventspace-hook! + set-front-hook! + set-menu-bar-hooks! + set-fixup-window-locations! + post-dummy-event + + try-to-sync-refresh) + + ;; from common/queue: + current-eventspace + queue-event + yield) + +(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray) +(import-protocol NSApplicationDelegate) + +;; Extreme hackery to hide original arguments from +;; NSApplication, because NSApplication wants to turn +;; the arguments into `application:openFile:' calls. +;; To hide the arguments, we replace the implementation +;; of `arguments' in the NSProcessInfo object. +(define (hack-argument-replacement self method) + (tell NSArray + arrayWithObjects: #:type (_vector i _NSString) (vector (path->string (find-system-path 'exec-file))) + count: #:type _NSUInteger 1)) +(let ([m (class_getInstanceMethod NSProcessInfo (selector arguments))]) + (void (method_setImplementation m hack-argument-replacement))) + +(define app (tell NSApplication sharedApplication)) + +(define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) + [] + [-a _int (applicationShouldTerminate: [_id app]) + (queue-quit-event) + 0] + [-a _BOOL (openPreferences: [_id app]) + (queue-prefs-event) + #t] + [-a _BOOL (validateMenuItem: [_id menuItem]) + (if (ptr-equal? (selector openPreferences:) + (tell #:type _SEL menuItem action)) + (not (eq? (application-pref-handler) nothing-application-pref-handler)) + (super-tell #:type _BOOL validateMenuItem: menuItem))] + [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) + (queue-file-event (string->path filename))] + [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?]) + ;; If we have any visible windows, return #t to do the default thing. + ;; Otherwise return #f, because we don't want any invisible windows resurrected. + has-visible?] + [-a _void (applicationDidChangeScreenParameters: notification) + ;; Screen changes sometimes make the event loop get stuck; + ;; hack: schedule a wake-up call in 5 seconds + (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]) + (parameterize ([current-custodian priviledged-custodian]) + (thread (lambda () (sleep 5.0))))) + ;; Also need to reset blit windows, since OS may move them incorrectly: + (fixup-window-locations)]) + +(define fixup-window-locations void) +(define (set-fixup-window-locations! f) (set! fixup-window-locations f)) + +;; In case we were started in an executable without a bundle, +;; explicitly register with the dock so the application can receive +;; keyboard events. +(define-cstruct _ProcessSerialNumber + ([highLongOfPSN _ulong] + [lowLongOfPSN _ulong])) +(define kCurrentProcess 2) +(define kProcessTransformToForegroundApplication 1) +(define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer + _uint32 + -> _OSStatus)) +(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) + kProcessTransformToForegroundApplication)) + +(define app-delegate (tell (tell MyApplicationDelegate alloc) init)) +(tellv app setDelegate: app-delegate) +(unless (scheme_register_process_global "Racket-GUI-no-front" #f) + (tellv app activateIgnoringOtherApps: #:type _BOOL #t)) + +;; For some reason, nextEventMatchingMask:... gets stuck if the +;; display changes, and it doesn't even send the +;; `applicationDidChangeScreenParameters:' callback. Unstick +;; it by posting a dummy event, since we fortunately can receive +;; a callback via CGDisplayRegisterReconfigurationCallback(). +;; This seems to unstick things enough that `applicationDidChangeScreenParameters:' +;; is called, but sometimes the event loop gets stuck after +;; that, so there's an additional hack above. +(define-appserv CGDisplayRegisterReconfigurationCallback + (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) +(define (on-screen-changed) (post-dummy-event)) +(void + (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) + +(tellv app finishLaunching) + +;; ------------------------------------------------------------ +;; Create an event to post when MzScheme has been sleeping but is +;; ready to wake up + +(import-class NSEvent) +(define wake-evt + (tell NSEvent + otherEventWithType: #:type _int NSApplicationDefined + location: #:type _NSPoint (make-NSPoint 0.0 0.0) + modifierFlags: #:type _NSUInteger 0 + timestamp: #:type _double 0.0 + windowNumber: #:type _NSUInteger 0 + context: #:type _pointer #f + subtype: #:type _short 0 + data1: #:type _NSInteger 0 + data2: #:type _NSInteger 0)) +(retain wake-evt) +(define (post-dummy-event) + (tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES)) + +;; This callback will be invoked by the CoreFoundation run loop +;; when data is available on `ready_sock', which is used to indicate +;; that MzScheme would like to wake up (and posting a Cocoa event +;; causes the event-getting function to unblock). +(define (socket_callback) + (read2 ready_sock read-buf 1) + (post-dummy-event)) + +;; ------------------------------------------------------------ +;; Create a pipe's pair of file descriptors, used to communicate +;; from the MzScheme-sleep thread to the CoreFoundation run loop. + +(define pipe2 (get-ffi-obj 'pipe #f (_fun _pointer -> _int))) +(define write2 (get-ffi-obj 'write #f (_fun _int _pointer _long -> _long))) +(define read2 (get-ffi-obj 'read #f (_fun _int _pointer _long -> _long))) +(define read-buf (make-bytes 1)) +(define-values (ready_sock write_sock) + (let ([s (malloc 'raw 2 _int)]) + (unless (zero? (pipe2 s)) + (error "pipe didn't create fds")) + (let ([r (ptr-ref s _int 0)] + [w (ptr-ref s _int 1)]) + (free s) + (values r w)))) + +;; ------------------------------------------------------------ +;; Register the event-posting callback on `ready_sock' with +;; the CoreFoundation run loop + +(define _CFIndex _uint) +(define _CFStringRef _NSString) +(define-cstruct _CFSocketContext ([version _CFIndex] + [info _pointer] + [retain (_fun _pointer -> _pointer)] + [release (_fun _pointer -> _void)] + [copyDescription (_fun _pointer -> _CFStringRef)])) +(define (sock_retain v) #f) +(define (sock_release v) (void)) +(define (sock_copy_desc v) "sock") +(define sock-context (make-CFSocketContext 0 #f sock_retain sock_release sock_copy_desc)) + +(define _CFRunLoopRef _pointer) +(define _CFAllocatorRef _pointer) +(define _CFSocketRef _pointer) +(define _CFRunLoopSourceRef _pointer) +(define _CFSocketNativeHandle _int) +(define _CFOptionFlags _uint) +(define _CFSocketCallBack (_fun -> _void)) +(define-cf CFAllocatorGetDefault (_fun -> _pointer)) +(define-cf CFSocketCreateWithNative (_fun _CFAllocatorRef + _CFSocketNativeHandle + _CFOptionFlags + _CFSocketCallBack + _CFSocketContext-pointer + -> _CFSocketRef)) +(define-cf CFSocketCreateRunLoopSource (_fun _CFAllocatorRef + _CFSocketRef + _CFIndex + -> _CFRunLoopSourceRef)) +(define-cf CFRunLoopAddSource (_fun _CFRunLoopRef + _CFRunLoopSourceRef + _CFStringRef + -> _void)) +(define-cf kCFRunLoopDefaultMode _CFStringRef) + +(define kCFSocketReadCallBack 1) + +(import-class NSRunLoop) +(let* ([rl (tell #:type _CFRunLoopRef (tell NSRunLoop currentRunLoop) getCFRunLoop)] + [cfs (CFSocketCreateWithNative (CFAllocatorGetDefault) ready_sock kCFSocketReadCallBack + socket_callback sock-context)] + [source (CFSocketCreateRunLoopSource (CFAllocatorGetDefault) cfs 0)]) + (CFRunLoopAddSource rl source kCFRunLoopDefaultMode)) + +;; ------------------------------------------------------------ +;; Another hack: +;; Install a run-loop observer that noticed when the core run loop +;; is exited multiple times during a single wait for a Cocoa event. +;; When that happens, it's a sign that something has gone wrong, +;; and we should interrupt the event wait and try again. This happens +;; when the user hides the application and then clicks on the dock +;; icon. (But why does that happen?) + +(define _Boolean _BOOL) +(define-cf kCFRunLoopCommonModes _pointer) +(define-cf CFRunLoopObserverCreate (_fun _pointer ; CFAllocatorRef + _int ; CFOptionFlags + _Boolean ; repeats? + _CFIndex ; order + (_fun #:atomic? #t _pointer _int _pointer -> _void) + _pointer ; CFRunLoopObserverContext + -> _pointer)) +(define-cf CFRunLoopAddObserver (_fun _pointer _pointer _pointer -> _void)) +(define-cf CFRunLoopGetMain (_fun -> _pointer)) +(define kCFRunLoopExit (arithmetic-shift 1 7)) +(define-mz scheme_signal_received (_fun -> _void)) +(define already-exited? #f) +(define sleeping? #f) +(define (exiting-run-loop x y z) + (when sleeping? + (if already-exited? + (scheme_signal_received) + (set! already-exited? #t)))) +(let ([o (CFRunLoopObserverCreate #f kCFRunLoopExit #t 0 exiting-run-loop #f)]) + (CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes)) + +;; ------------------------------------------------------------ +;; Cocoa event pump + +(define-cocoa NSDefaultRunLoopMode _id) ; more specifically an _NSString, but we don't need a conversion + +(import-class NSDate) +(define distantFuture (tell NSDate distantFuture)) + +(define eventspace-hook (lambda (e) #f)) +(define (set-eventspace-hook! proc) (set! eventspace-hook proc)) + +(define front-hook (lambda () (values #f #f))) +(define (set-front-hook! proc) (set! front-hook proc)) + +(define in-menu-bar-range? (lambda (p) #f)) +(define (set-menu-bar-hooks! r?) + (set! in-menu-bar-range? r?)) + +(define events-suspended? #f) +(define was-menu-bar #f) + +(define avoid-mouse-key-until #f) + +(define (check-menu-bar-click evt) + (if (and evt + (= 14 (tell #:type _NSUInteger evt type)) + (= 7 (tell #:type _short evt subtype)) + (not (tell evt window)) + (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow))) + ;; Mouse down in the menu bar: + (let-values ([(f e) (front-hook)]) + (when e + ;; Avoid spiral of on-demand calls: + (unless (and was-menu-bar + (eq? e (weak-box-value was-menu-bar))) + ;; Don't handle further events until we've made an effort + ;; at on-demand notifications. + (set! was-menu-bar (make-weak-box e)) + (set! events-suspended? #t) + (let* ([c (make-custodian)] + [t (parameterize ([current-custodian c]) + (thread (lambda () + (sleep 2) + ;; on-demand took too long, so wait + ;; until the application can catch up + (set! events-suspended? #f))))]) + (queue-event e (lambda () + (send f on-menu-click) + (set! events-suspended? #f) + (custodian-shutdown-all c))))))) + (set! was-menu-bar #f))) + +;; Call this function only in atomic mode: +(define (check-one-event wait? dequeue?) + (pre-event-sync wait?) + (clean-up-deleted) + (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) + (when (and events-suspended? wait?) + (set! was-menu-bar #f) + (set! events-suspended? #f)) + (when (and avoid-mouse-key-until + ((current-inexact-milliseconds) . > . avoid-mouse-key-until)) + (set! avoid-mouse-key-until #f)) + (begin0 + (let ([evt (if events-suspended? + #f + (tell app nextEventMatchingMask: #:type _NSUInteger (if (and (not wait?) + avoid-mouse-key-until) + (- NSAnyEventMask + MouseAndKeyEventMask) + NSAnyEventMask) + untilDate: (if wait? distantFuture #f) + inMode: NSDefaultRunLoopMode + dequeue: #:type _BOOL dequeue?))]) + (when evt (check-menu-bar-click evt)) + (and evt + (or (not dequeue?) + (let ([e (eventspace-hook (tell evt window))]) + (if e + (let ([mouse-or-key? + (bitwise-bit-set? MouseAndKeyEventMask + (tell #:type _NSInteger evt type))]) + ;; If it's a mouse or key event, delay further + ;; dequeue of mouse and key events until this + ;; one can be handled. + (when mouse-or-key? + (set! avoid-mouse-key-until + (+ (current-inexact-milliseconds) 200.0))) + (retain evt) + (queue-event e (lambda () + (call-as-nonatomic-retry-point + (lambda () + ;; in atomic mode + (with-autorelease + (tellv app sendEvent: evt) + (release evt)))) + (when mouse-or-key? + (set! avoid-mouse-key-until #f))))) + (tellv app sendEvent: evt))) + #t))) + (tellv pool release)))) + +;; Call this function only in atomic mode: +(define (dispatch-all-ready) + (when (check-one-event #f #t) + (dispatch-all-ready))) + +(define (cocoa-start-event-pump) + (thread (lambda () + (let loop () + ;; Wait 50 msecs between event polling, unless nothing + ;; else is going on: + (sync/timeout 0.05 (system-idle-evt)) + ;; Wait until event is ready --- but waiting is implemented + ;; by polling: + (sync queue-evt) + ;; Something is ready, so dispatch: + (atomically (dispatch-all-ready)) + ;; Periodically free everything in the default allocation pool: + (queue-autorelease-flush) + (loop))))) + +(set-check-queue! + ;; Called through an atomic callback: + (lambda () (check-one-event #f #f))) + +(define (try-to-sync-refresh) + ;; atomically => outside of the event loop + (atomically + (pre-event-sync #t))) + +;; ------------------------------------------------------------ +;; Install an alternate "sleep" function (in the PLT Scheme core) +;; that wakes up if any Cocoa event is ready. + +(define-mz scheme_start_sleeper_thread (_fun _fpointer _float _pointer _int -> _void)) +(define-mz scheme_end_sleeper_thread (_fun -> _void)) + +(define-mz scheme_sleep _pointer) + +;; Called through an atomic callback: +(define (sleep-until-event secs fds) + (set! sleeping? #t) + (set! already-exited? #f) + (scheme_start_sleeper_thread scheme_sleep secs fds write_sock) + (check-one-event #t #f) ; blocks until an event is ready + (scheme_end_sleeper_thread) + (set! sleeping? #f)) + +(define (cocoa-install-event-wakeup) + (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it + (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event + (_fun #:atomic? #t + _float _pointer -> _void)))) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt new file mode 100644 index 00000000..ff799116 --- /dev/null +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -0,0 +1,143 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "item.rkt" + "button.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt" + "image.rkt") + +(provide + (protect-out radio-box%)) + +;; ---------------------------------------- + +(import-class NSMatrix NSButtonCell) + +(define NSRadioModeMatrix 0) +(define NSListModeMatrix 2) + +(define-objc-class MyMatrix NSMatrix + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (clicked: [_id sender]) + (queue-window*-event wxb (lambda (wx) (send wx clicked))))) + +(define-objc-class MyImageButtonCell NSButtonCell + [img] + [-a _NSSize (cellSize) + (let ([s (super-tell #:type _NSSize cellSize)]) + (if img + (let ([s2 (tell #:type _NSSize img size)]) + (make-NSSize (+ (NSSize-width s) (NSSize-width s2)) + (max (NSSize-height s) (NSSize-height s2)))) + s))] + [-a _void (drawInteriorWithFrame: [_NSRect f] inView: [_id view]) + (super-tell #:type _void drawInteriorWithFrame: #:type _NSRect f inView: view) + (when img + (let ([size (tell #:type _NSSize img size)]) + (tellv img + drawInRect: #:type _NSRect (make-NSRect + (make-NSPoint + (+ (NSPoint-x (NSRect-origin f)) + (- (NSSize-width (NSRect-size f)) + (NSSize-width size))) + (+ (NSPoint-y (NSRect-origin f)) + (quotient (- (NSSize-height (NSRect-size f)) + (NSSize-height size)) + 2))) + size) + fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) size) + operation: #:type _int 1 + fraction: #:type _CGFloat 1.0)))]) + +(defclass radio-box% item% + (init parent cb label + x y w h + labels + val + style + font) + (inherit get-cocoa set-focus init-font register-as-child) + + (define horiz? (and (memq 'horizontal style) #t)) + + (super-new [parent parent] + [cocoa + (let ([cocoa + (as-objc-allocation + (tell (tell MyMatrix alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize w h)) + mode: #:type _int NSRadioModeMatrix + cellClass: (if (andmap string? labels) + NSButtonCell + MyImageButtonCell) + numberOfRows: #:type _NSInteger (if horiz? 1 (length labels)) + numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))]) + (for ([label (in-list labels)] + [i (in-naturals)]) + (let ([button (tell cocoa + cellAtRow: #:type _NSInteger (if horiz? 0 i) + column: #:type _NSInteger (if horiz? i 0))]) + (if (and (not (string? label)) + (send label ok?)) + (begin + (tellv button setTitle: #:type _NSString "") + (set-ivar! button img (bitmap->image label))) + (begin + (init-font button font) + (tellv button setTitleWithMnemonic: #:type _NSString (if (string? label) + label + "")))) + (tellv button setButtonType: #:type _int NSRadioButton))) + (tellv cocoa sizeToFit) + (tellv cocoa setTarget: cocoa) + (tellv cocoa setAction: #:type _SEL (selector clicked:)) + cocoa)] + [callback cb] + [no-show? (memq 'deleted style)]) + + (define count (length labels)) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))) + + (define/public (button-focus i) + (if (= i -1) + 0 + (set-focus))) + + (define/private (get-button i) + (tell (get-cocoa) + cellAtRow: #:type _NSUInteger (if horiz? 0 i) + column: #:type _NSUInteger (if horiz? i 0))) + + (define/public (enable-button i on?) + (tellv (get-button i) setEnabled: #:type _BOOL on?)) + + (define/public (set-selection i) + (if (= i -1) + (begin + ;; Need to change to NSListModeMatrix to disable all. + ;; It seem that we don't have to change the mode back, for some reason. + (tellv (get-cocoa) setMode: #:type _int NSListModeMatrix) + (tellv (get-cocoa) deselectAllCells)) + (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i) + column: #:type _NSInteger (if horiz? i 0)))) + (define/public (get-selection) + (if horiz? + (tell #:type _NSInteger (get-cocoa) selectedColumn) + (tell #:type _NSInteger (get-cocoa) selectedRow))) + (define/public (number) count) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt new file mode 100644 index 00000000..146352ed --- /dev/null +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -0,0 +1,163 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + "../../syntax.rkt" + "item.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "window.rkt" + "../common/event.rkt" + "../common/queue.rkt" + "../common/freeze.rkt" + "../../lock.rkt") + +(provide + (protect-out slider%)) + +;; ---------------------------------------- + +(import-class NSSlider NSTextField NSView) + +(define-objc-class MySlider NSSlider + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (changed: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx + (send wx update-message) + (queue-window-event wx (lambda () (send wx changed))) + (constrained-reply + (send wx get-eventspace) + (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void)))))) + +(defclass slider% item% + (init parent cb + label + val lo hi + x y w + style + font) + (inherit get-cocoa register-as-child + init-font) + + (define vert? (memq 'vertical style)) + + (define slider-cocoa + (let ([cocoa (as-objc-allocation + (tell (tell MySlider alloc) init))]) + (tellv cocoa setMinValue: #:type _double* lo) + (tellv cocoa setMaxValue: #:type _double* hi) + (tellv cocoa setDoubleValue: #:type _double* val) + ;; heuristic: show up to tick marks: + (when ((- hi lo) . < . 64) + (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) + (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t)) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (if vert? 24 32) + (if vert? 64 24)))) + (tellv cocoa setContinuous: #:type _BOOL #t) + ;; (tellv cocoa sizeToFit) + cocoa)) + + (define-values (message-cocoa message-w message-h) + (if (memq 'plain style) + (values #f #f #f) + (let ([cocoa (as-objc-allocation + (tell (tell NSTextField alloc) init))]) + (init-font cocoa font) + (tellv cocoa setSelectable: #:type _BOOL #f) + (tellv cocoa setEditable: #:type _BOOL #f) + (tellv cocoa setBordered: #:type _BOOL #f) + (tellv cocoa setDrawsBackground: #:type _BOOL #f) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" hi)) + (tellv cocoa sizeToFit) + (let ([r1 (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" lo)) + (tellv cocoa sizeToFit) + (let ([r2 (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val)) + (values cocoa + (max (NSSize-width (NSRect-size r1)) + (NSSize-width (NSRect-size r2))) + (max (NSSize-height (NSRect-size r1)) + (NSSize-height (NSRect-size r2))))))))) + + (define cocoa + (if message-cocoa + (let* ([f (tell #:type _NSRect slider-cocoa frame)] + [w (+ (if vert? + message-w + 0) + (NSSize-width (NSRect-size f)))] + [h (+ (if vert? + 0 + message-h) + (NSSize-height (NSRect-size f)))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (make-NSRect + (make-init-point x y) + (make-NSSize w h))))]) + (tellv cocoa addSubview: slider-cocoa) + (tellv cocoa addSubview: message-cocoa) + (arrange-parts w h) + cocoa)) + slider-cocoa)) + + (define/private (arrange-parts w h) + (tellv slider-cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 + (if vert? 0 message-h)) + (make-NSSize (- w (if vert? message-w 0)) + (- h (if vert? 0 message-h))))) + (tellv message-cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint (if vert? + (- w message-w) + (/ (- w message-w) 2)) + (if vert? + (/ (- h message-h) 2) + 0)) + (make-NSSize message-w message-h)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when message-cocoa + (arrange-parts w h))) + + (when message-cocoa + (set-ivar! slider-cocoa wxb (->wxb this))) + + (super-new [parent parent] + [cocoa cocoa] + [callback cb] + [no-show? (memq 'deleted style)]) + + (define/override (get-cocoa-control) slider-cocoa) + + (tellv slider-cocoa setTarget: slider-cocoa) + (tellv slider-cocoa setAction: #:type _SEL (selector changed:)) + + (define callback cb) + (define/public (changed) + (callback this (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)]))) + + + (define/public (set-value v) + (atomically + (tellv slider-cocoa setDoubleValue: #:type _double* v) + (update-message v))) + (define/public (get-value) + (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue)))) + + (define/public (update-message [val (get-value)]) + (tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) + diff --git a/collects/mred/private/wx/cocoa/sound.rkt b/collects/mred/private/wx/cocoa/sound.rkt new file mode 100644 index 00000000..ec31b205 --- /dev/null +++ b/collects/mred/private/wx/cocoa/sound.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt") + +(provide + (protect-out play-sound)) + +(import-class NSSound) + +(define-objc-class MySound NSSound + [result + sema] + [-a _void (sound: [_id sound] didFinishPlaying: [_BOOL ok?]) + (set! result ok?) + (semaphore-post sema) + (tellv self release)]) + +(define (play-sound path async?) + (let ([s (as-objc-allocation + (tell (tell MySound alloc) + initWithContentsOfFile: #:type _NSString (if (path? path) + (path->string path) + path) + byReference: #:type _BOOL #t))] + [sema (make-semaphore)]) + (tellv s setDelegate: s) + (set-ivar! s sema sema) + (tellv s retain) ; don't use `retain', because we dont' want auto-release + (tellv s play) + (if async? + (begin + (semaphore-wait sema) + (get-ivar s result)) + #t))) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt new file mode 100644 index 00000000..5b5b2205 --- /dev/null +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -0,0 +1,188 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/objc + racket/runtime-path + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "panel.rkt" + "queue.rkt" + "../common/event.rkt" + "../common/procs.rkt" + (for-syntax racket/base)) + +(provide + (protect-out tab-panel%)) + +(define-runtime-path psm-tab-bar-dir + '(so "PSMTabBarControl.framework")) + +;; Load PSMTabBarControl: +(void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))) +(define NSNoTabsNoBorder 6) + +(define NSDefaultControlTint 0) +(define NSClearControlTint 7) + +(import-class NSView NSTabView NSTabViewItem PSMTabBarControl) +(import-protocol NSTabViewDelegate) + +(define NSOrderedAscending -1) +(define NSOrderedSame 0) +(define NSOrderedDescending 1) +(define (order-content-first a b data) + (cond + [(ptr-equal? a data) NSOrderedDescending] + [(ptr-equal? b data) NSOrderedAscending] + [else NSOrderedSame])) +(define order_content_first (function-ptr order-content-first + (_fun #:atomic? #t _id _id _id -> _int))) + +(define-objc-class MyTabView NSTabView + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) + (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) + +(define-objc-class MyPSMTabBarControl PSMTabBarControl + #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) + [wxb] + (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) + (super-tell #:type _void tabView: cocoa didSelectTabViewItem: item-cocoa) + (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) + +(defclass tab-panel% (panel-mixin window%) + (init parent + x y w h + style + labels) + (inherit get-cocoa register-as-child + is-window-enabled? + block-mouse-events) + + (define tabv-cocoa (as-objc-allocation + (tell (tell MyTabView alloc) init))) + (define cocoa (if (not (memq 'border style)) + (as-objc-allocation + (tell (tell NSView alloc) init)) + tabv-cocoa)) + + (define control-cocoa + (and (not (memq 'border style)) + (let ([i (as-objc-allocation + (tell (tell MyPSMTabBarControl alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize 200 22))))]) + (tellv cocoa addSubview: i) + (tellv cocoa addSubview: tabv-cocoa) + (tellv tabv-cocoa setDelegate: i) + (tellv tabv-cocoa setTabViewType: #:type _int NSNoTabsNoBorder) + (tellv i setTabView: tabv-cocoa) + (tellv i setStyleNamed: #:type _NSString "Aqua") + ;;(tellv i setSizeCellsToFit: #:type _BOOL #t) + (tellv i setDisableTabClose: #:type _BOOL #t) + i))) + + (define item-cocoas + (for/list ([lbl (in-list labels)]) + (let ([item (as-objc-allocation + (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) + (tellv item setLabel: #:type _NSString (label->plain-label lbl)) + (tellv tabv-cocoa addTabViewItem: item) + item))) + (if control-cocoa + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize 50 22))) + (let ([sz (tell #:type _NSSize tabv-cocoa minimumSize)]) + (tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz)) + (tellv tabv-cocoa setDelegate: tabv-cocoa))) + + (define content-cocoa + (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect)))) + (tellv tabv-cocoa addSubview: content-cocoa) + + (define/override (get-cocoa-content) content-cocoa) + (define/override (get-cocoa-cursor-content) tabv-cocoa) + (define/override (set-size x y w h) + (super set-size x y w h) + (when control-cocoa + (let ([r (tell #:type _NSRect cocoa frame)]) + (tellv control-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint + 0 + (- (NSSize-height (NSRect-size r)) 22)) + (make-NSSize + (NSSize-width (NSRect-size r)) + 22))) + (tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize + (NSSize-width (NSRect-size r)) + (- (NSSize-height (NSRect-size r)) 22)))))) + (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect))) + + (define/public (set-label i str) + (tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str))) + + (define/public (set-selection i) + (tellv tabv-cocoa selectTabViewItem: (list-ref item-cocoas i))) + (define/public (get-selection) + (item->index (tell tabv-cocoa selectedTabViewItem))) + + (define (item->index tv) + (for/or ([c (in-list item-cocoas)] + [i (in-naturals)]) + (and (ptr-equal? c tv) i))) + + (public [append* append]) + (define (append* lbl) + (let ([item (as-objc-allocation + (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) + (tellv item setLabel: #:type _NSString (label->plain-label lbl)) + (tellv tabv-cocoa addTabViewItem: item) + (set! item-cocoas (append item-cocoas (list item))) + ;; Sometimes the sub-view for the tab buttons gets put in front + ;; of the content view, so fix the order: + (tellv tabv-cocoa sortSubviewsUsingFunction: #:type _fpointer order_content_first + context: #:type _pointer content-cocoa))) + + (define/public (delete i) + (let ([item-cocoa (list-ref item-cocoas i)]) + (tellv tabv-cocoa removeTabViewItem: item-cocoa) + (set! item-cocoas (remq item-cocoa item-cocoas)))) + + (define/public (set choices) + (for ([item-cocoa (in-list item-cocoas)]) + (tellv tabv-cocoa removeTabViewItem: item-cocoa)) + (set! item-cocoas null) + (for ([lbl (in-list choices)]) + (append* lbl))) + + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/public (do-callback) + (callback this (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))) + + (super-new [parent parent] + [cocoa cocoa] + [no-show? (memq 'deleted style)]) + + (when control-cocoa + (set-ivar! control-cocoa wxb (->wxb this))) + + (define/override (enable-window on?) + (super enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (block-mouse-events (not on?)) + (tellv tabv-cocoa setControlTint: #:type _int + (if on? NSDefaultControlTint NSClearControlTint)) + (when control-cocoa + (tellv control-cocoa setEnabled: #:type _BOOL on?)))) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?))) + diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt new file mode 100644 index 00000000..665aeae1 --- /dev/null +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + "../../lock.rkt" + "utils.rkt") + +(provide + (protect-out _NSInteger _NSUInteger _OSStatus + _CGFloat + _NSPoint _NSPoint-pointer (struct-out NSPoint) + _NSSize _NSSize-pointer (struct-out NSSize) + _NSRect _NSRect-pointer (struct-out NSRect) + _NSRange _NSRange-pointer (struct-out NSRange) + NSObject + NSString _NSString + NSNotFound)) + +(define _NSInteger _long) +(define _NSUInteger _ulong) + +(define _OSStatus _sint32) + +(define 64-bit? (= (ctype-sizeof _long) 8)) + +(define _CGFloat (make-ctype (if 64-bit? _double _float) + (lambda (v) (if (and (number? v) + (exact? v)) + (exact->inexact v) + v)) + #f)) + +(define-cstruct _NSPoint ([x _CGFloat] + [y _CGFloat])) +(define-cstruct _NSSize ([width _CGFloat] + [height _CGFloat])) + +(define-cstruct _NSRect ([origin _NSPoint][size _NSSize])) + +(define-cstruct _NSRange ([location _NSUInteger] + [length _NSUInteger])) + +(import-class NSObject NSString) + +(define strings (make-weak-hash)) +(define _NSString (make-ctype _id + (lambda (v) + (or (hash-ref strings v #f) + (let ([s (as-objc-allocation + (tell (tell NSString alloc) + initWithUTF8String: + #:type _string + v))]) + (hash-set! strings v s) + s))) + (lambda (v) + (atomically + (with-autorelease + (let ([s (tell #:type _bytes v UTF8String)]) + (bytes->string/utf-8 s))))))) + +(define NSNotFound (if 64-bit? + #x7fffffffffffffff + #x7fffffff)) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt new file mode 100644 index 00000000..fff2a032 --- /dev/null +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -0,0 +1,89 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + ffi/unsafe/alloc + ffi/unsafe/define + "../common/utils.rkt" + "../../lock.rkt") + +(provide + (protect-out cocoa-lib + cf-lib + define-cocoa + define-cf + define-appserv + define-appkit + as-objc-allocation + as-objc-allocation-with-retain + clean-up-deleted + retain release + with-autorelease + clean-menu-label + ->wxb + ->wx + old-cocoa? + version-10.6-or-later?) + define-mz) + +(define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) +(define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) +(define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices"))) +(define appkit-lib (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit"))) + +(define-ffi-definer define-cocoa cocoa-lib) +(define-ffi-definer define-cf cf-lib) +(define-ffi-definer define-appserv appserv-lib) +(define-ffi-definer define-appkit appkit-lib) + +(define delete-me null) + +(define (objc-delete o) + (tellv o release)) + +(define (clean-up-deleted) + (free-remembered-now objc-delete)) + +(define objc-allocator (allocator remember-to-free-later)) + +(define-syntax-rule (as-objc-allocation expr) + ((objc-allocator (lambda () expr)))) + +(define-syntax-rule (as-objc-allocation-with-retain expr) + ((objc-allocator (lambda () (let ([v expr]) + (tellv v retain) + v))))) + +(define release ((deallocator) objc-delete)) +(define retain ((retainer release car) + (lambda (obj) + (tellv obj retain)))) + +(import-class NSAutoreleasePool) + +;; Use `with-autorelease' and `call-with-autorelease' +;; in atomic mode +(define-syntax-rule (with-autorelease expr ...) + (call-with-autorelease (lambda () expr ...))) +(define (call-with-autorelease thunk) + (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) + (begin0 + (thunk) + (tellv pool release)))) + +(define (clean-menu-label str) + (regexp-replace* #rx"&(.)" str "\\1")) + +(define (->wxb wx) + (make-weak-box wx)) + +(define (->wx wxb) + (and wxb + (weak-box-value wxb))) + +(define-appkit NSAppKitVersionNumber _double) + +(define old-cocoa? + ; earlier than 10.5? + (NSAppKitVersionNumber . < . 949)) +(define (version-10.6-or-later?) + (NSAppKitVersionNumber . >= . 1038)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt new file mode 100644 index 00000000..dbe29c72 --- /dev/null +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -0,0 +1,835 @@ +#lang racket/base +(require ffi/unsafe/objc + ffi/unsafe + racket/class + "queue.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "keycode.rkt" + "pool.rkt" + "cursor.rkt" + "../common/local.rkt" + "../../lock.rkt" + "../common/event.rkt" + "../common/queue.rkt" + "../common/delay.rkt" + "../../syntax.rkt" + "../common/freeze.rkt") + +(provide + (protect-out window% + + FocusResponder + KeyMouseResponder + KeyMouseTextResponder + CursorDisplayer + + queue-window-event + queue-window-refresh-event + queue-window*-event + request-flush-delay + cancel-flush-delay + make-init-point + flush-display + + special-control-key + special-option-key)) + +(define-local-member-name flip-client) + +;; ---------------------------------------- + +(define special-control-key? #f) +(define special-control-key + (case-lambda + [() special-control-key?] + [(on?) (set! special-control-key? (and on? #t))])) + +(define special-option-key? #f) +(define special-option-key + (case-lambda + [() special-option-key?] + [(on?) (set! special-option-key? (and on? #t))])) + +;; ---------------------------------------- + +(define-objc-mixin (FocusResponder Superclass) + [wxb] + [-a _BOOL (acceptsFirstResponder) + (let ([wx (->wx wxb)]) + (or (not wx) + (send wx can-be-responder?)))] + [-a _BOOL (becomeFirstResponder) + (and (super-tell becomeFirstResponder) + (let ([wx (->wx wxb)]) + (when wx (send wx is-responder wx #t)) + #t))] + [-a _BOOL (resignFirstResponder) + (and (super-tell resignFirstResponder) + (let ([wx (->wx wxb)]) + (when wx (send wx is-responder wx #f)) + #t))] + [-a _void (changeColor: [_id sender]) + (let ([wx (->wx wxb)]) + (when wx (send wx on-color-change)))]) + +(import-class NSArray) +(import-protocol NSTextInput) + +(define current-insert-text (make-parameter #f)) +(define current-set-mark (make-parameter #f)) + +(define NSDragOperationCopy 1) + +(import-class NSAttributedString) +(define _NSStringOrAttributed + (make-ctype _id + (lambda (v) + (cast v _NSString _id)) + (lambda (v) + (if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class)) + (tell #:type _NSString v string) + (cast v _id _NSString))))) + +(define-objc-mixin (KeyMouseResponder Superclass) + [wxb] + [-a _void (mouseDown: [_id event]) + (unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down) + (super-tell #:type _void mouseDown: event))] + [-a _void (mouseUp: [_id event]) + (unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up) + (super-tell #:type _void mouseUp: event))] + [-a _void (mouseDragged: [_id event]) + (unless (do-mouse-event wxb event 'motion #t #f #f) + (super-tell #:type _void mouseDragged: event))] + [-a _void (mouseMoved: [_id event]) + ;; This event is sent to the first responder, instead of the + ;; view under the mouse. + (let* ([win (tell event window)] + [view (and win (tell win contentView))] + [hit (and view (tell view hitTest: #:type _NSPoint + (tell #:type _NSPoint event locationInWindow)))]) + (let loop ([hit hit]) + (when hit + (if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:)) + (unless (tell #:type _BOOL hit doMouseMoved: event) + (super-tell #:type _void mouseMoved: event)) + (loop (tell hit superview))))))] + [-a _BOOL (doMouseMoved: [_id event]) + ;; called by mouseMoved: + (and + ;; Make sure we're in the right eventspace: + (let ([wx (->wx wxb)]) + (and wx + (eq? (current-eventspace) + (send wx get-eventspace)))) + ;; Right event space, so handle the event: + (do-mouse-event wxb event 'motion #f #f #f))] + [-a _void (mouseEntered: [_id event]) + (unless (do-mouse-event wxb event 'enter 'check 'check 'check) + (super-tell #:type _void mouseEntered: event))] + [-a _void (mouseExited: [_id event]) + (unless (do-mouse-event wxb event 'leave 'check 'check 'check) + (super-tell #:type _void mouseExited: event))] + [-a _void (rightMouseDown: [_id event]) + (unless (do-mouse-event wxb event 'right-down #f #f #t) + (super-tell #:type _void rightMouseDown: event))] + [-a _void (rightMouseUp: [_id event]) + (unless (do-mouse-event wxb event 'right-up #f #f #f) + (super-tell #:type _void rightMouseUp: event))] + [-a _void (rightMouseDragged: [_id event]) + (unless (do-mouse-event wxb event 'motion #f #f #t) + (super-tell #:type _void rightMouseDragged: event))] + [-a _void (otherMouseDown: [_id event]) + (unless (do-mouse-event wxb event 'middle-down #f #t #f) + (super-tell #:type _void otherMouseDown: event))] + [-a _void (otherMouseUp: [_id event]) + (unless (do-mouse-event wxb event 'middle-up #f #f #f) + (super-tell #:type _void otherMouseUp: event))] + [-a _void (otherMouseDragged: [_id event]) + (unless (do-mouse-event wxb event 'motion #f #t #f) + (super-tell #:type _void otherMouseDragged: event))] + + [-a _void (scrollWheel: [_id event]) + (unless (and (not (zero? (tell #:type _CGFloat event deltaY))) + (do-key-event wxb event self #f #t)) + (super-tell #:type _void scrollWheel: event))] + + [-a _void (keyDown: [_id event]) + (unless (do-key-event wxb event self #t #f) + (super-tell #:type _void keyDown: event))] + [-a _void (keyUp: [_id event]) + (unless (do-key-event wxb event self #f #f) + (super-tell #:type _void keyUp: event))] + [-a _void (insertText: [_NSStringOrAttributed str]) + (let ([cit (current-insert-text)]) + (if cit + (set-box! cit str) + (let ([wx (->wx wxb)]) + (post-dummy-event) ;; to wake up in case of character palette insert + (when wx + (queue-window-event wx (lambda () + (send wx key-event-as-string str)))))))] + + ;; for NSTextInput: + [-a _BOOL (hasMarkedText) (get-saved-marked wxb)] + [-a _id (validAttributesForMarkedText) + (tell NSArray array)] + [-a _void (unmarkText) + (set-saved-marked! wxb #f)] + [-a _NSRange (markedRange) + (let ([saved-marked (get-saved-marked wxb)]) + (make-NSRange 0 (if saved-marked 0 (length saved-marked))))] + [-a _NSRange (selectedRange) (make-NSRange 0 0)] + [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange]) + ;; We interpreter a call to `setMarkedText:' as meaning that the + ;; key is a dead key for composing some other character. + (let ([m (current-set-mark)]) (when m (set-box! m #t))) + ;; At the same time, we need to remember the text: + (set-saved-marked! wxb (range-substring aString selRange)) + (void)] + [-a _id (validAttributesForMarkedText) #f] + [-a _id (attributedSubstringFromRange: [_NSRange theRange]) + (let ([saved-marked (get-saved-marked wxb)]) + (and saved-marked + (let ([s (tell (tell NSAttributedString alloc) + initWithString: #:type _NSString + (range-substring saved-marked theRange))]) + (tellv s autorelease) + s)))] + + [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0] + [-a _NSInteger (conversationIdentifier) 0] + [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] + [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) + ;; This location is used to place a window for multi-character + ;; input, such as when typing Chinese with Pinyin + (let ([f (tell #:type _NSRect self frame)] + [pt (tell #:type _NSPoint (tell self window) + convertBaseToScreen: + #:type _NSPoint + (tell #:type _NSPoint self + convertPoint: #:type _NSPoint + (make-NSPoint 0 0) + toView: #f))]) + (make-NSRect pt (NSRect-size f)))] + + ;; Dragging: + [-a _int (draggingEntered: [_id info]) + NSDragOperationCopy] + [-a _BOOL (prepareForDragOperation: [_id info]) + #t] + [-a _BOOL (performDragOperation: [_id info]) + (let ([wx (->wx wxb)]) + (when wx + (with-autorelease + (let ([pb (tell info draggingPasteboard)]) + (let ([data (tell pb propertyListForType: NSFilenamesPboardType)]) + (when data + (for ([i (in-range (tell #:type _NSUInteger data count))]) + (let ([s (tell #:type _NSString data objectAtIndex: #:type _NSUInteger i)]) + (queue-window-event wx + (lambda () + (send wx do-on-drop-file s))))))))))) + #t]) +(define (set-saved-marked! wxb str) + (let ([wx (->wx wxb)]) + (when wx + (send wx set-saved-marked str)))) +(define (get-saved-marked wxb) + (let ([wx (->wx wxb)]) + (and wx + (send wx get-saved-marked)))) +(define (range-substring s range) + (let ([start (min (max 0 (NSRange-location range)) (string-length s))]) + (substring s start (max (min start (NSRange-length range)) (string-length s))))) + + +(define-objc-mixin (KeyMouseTextResponder Superclass) + #:mixins (KeyMouseResponder) + #:protocols (NSTextInput) + [wxb]) + +(define-objc-mixin (CursorDisplayer Superclass) + [wxb] + [-a _void (resetCursorRects) + (let ([wx (->wx wxb)]) + (when wx + (send wx reset-cursor-rects)))]) + +(define (do-key-event wxb event self down? wheel?) + (let ([wx (->wx wxb)]) + (and + wx + (let ([inserted-text (box #f)] + [set-mark (box #f)]) + (unless wheel? + ;; Calling `interpretKeyEvents:' allows key combinations to be + ;; handled, such as option-e followed by e to produce é. The + ;; call to `interpretKeyEvents:' typically calls `insertText:', + ;; so we set `current-insert-text' to tell `insertText:' to just + ;; give us back the text in the parameter. For now, we ignore the + ;; text and handle the event as usual, though probably we should + ;; be doing something with it. + (parameterize ([current-insert-text inserted-text] + [current-set-mark set-mark]) + (let ([array (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1)]) + (tellv self interpretKeyEvents: array) + (tellv array release)))) + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)] + [str (cond + [wheel? #f] + [(unbox set-mark) ""] ; => dead key for composing characters + [(unbox inserted-text)] + [else + (tell #:type _NSString event characters)])] + [control? (bit? modifiers NSControlKeyMask)] + [option? (bit? modifiers NSAlternateKeyMask)] + [delta-y (and wheel? + (tell #:type _CGFloat event deltaY))] + [codes (cond + [wheel? (if (positive? delta-y) + '(wheel-up) + '(wheel-down))] + [(map-key-code (tell #:type _ushort event keyCode)) + => list] + [(string=? "" str) '(#\nul)] + [(and (= 1 (string-length str)) + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1F) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0))))))) + => list] + [else str])]) + (for/fold ([result #f]) ([one-code codes]) + (or + ;; Handle one key event + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code one-code] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down control?] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down option?] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (unless wheel? + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (when (and (or (and option? + special-option-key?) + (and control? + (equal? (send k get-key-code) #\u00))) + (send k get-other-altgr-key-code)) + ;; swap altenate with main + (let ([other (send k get-other-altgr-key-code)]) + (send k set-other-altgr-key-code (send k get-key-code)) + (send k set-key-code other))) + (unless down? + ;; swap altenate with main + (send k set-key-release-code (send k get-key-code)) + (send k set-key-code 'release))) + (if (send wx definitely-wants-event? k) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-char/sync k))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t)))) + result))))))) + +(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) + (let ([wx (->wx wxb)]) + (and + wx + (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] + [bit? (lambda (m b) (positive? (bitwise-and m b)))] + [pos (tell #:type _NSPoint event locationInWindow)]) + (let-values ([(x y) (send wx window-point-to-view pos)] + [(control-down) (bit? modifiers NSControlKeyMask)] + [(l?) (if (eq? l? 'check) + (send wx get-last-left-button) + l?)] + [(m?) (if (eq? m? 'check) + (send wx get-last-middle-button) + m?)] + [(r?) (if (eq? r? 'check) + (send wx get-last-right-button) + r?)]) + (let ([l? (and l? (not control-down))] + [r? (or r? (and l? control-down))]) + (send wx set-last-buttons l? m? r?) + (let ([m (new mouse-event% + [event-type (if control-down ctl-kind kind)] + [left-down l?] + [middle-down m?] + [right-down r?] + [x (->long x)] + [y (->long y)] + [shift-down (bit? modifiers NSShiftKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (cond + [(send m dragging?) (void)] + [(send m button-down?) + (send wx set-sticky-cursor) + (send wx start-no-cursor-rects)] + [(or l? m? r?) (void)] + [else (send wx end-no-cursor-rects)]) + (if (send wx definitely-wants-event? m) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event/sync m))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t))))))))) + +(define-cocoa NSFilenamesPboardType _id) + +(define window% + (class object% + (init-field parent + cocoa + [no-show? #f]) + + (super-new) + + (queue-autorelease-flush) + + (define eventspace (if parent + (send parent get-eventspace) + (current-eventspace))) + + (when (eventspace-shutdown? eventspace) + (error '|GUI object initialization| "the eventspace has been shutdown")) + + (set-ivar! cocoa wxb (->wxb this)) + + (unless no-show? + (show #t)) + + (define/public (focus-is-on on?) + (void)) + + (define is-responder? #f) + + (define/public (is-responder wx on?) + (unless (eq? on? is-responder?) + (set! is-responder? (and on? #t)) + (send parent is-responder wx on?))) + + (define/public (hide-children) + (is-responder this #f) + (focus-is-on #f)) + (define/public (show-children) + (void)) + (define/public (fixup-locations-children) + (void)) + (define/public (fix-dc) + (void)) + (define/public (paint-children) + (void)) + + (define/public (get-cocoa) cocoa) + (define/public (get-cocoa-content) cocoa) + (define/public (get-cocoa-cursor-content) (get-cocoa-content)) + (define/public (get-cocoa-window) (send parent get-cocoa-window)) + (define/public (get-wx-window) (send parent get-wx-window)) + + (define/public (get-dialog-level) + ;; called in event-pump thread + (send parent get-dialog-level)) + + (define/public (make-graphics-context) + (and parent + (send parent make-graphics-context))) + + (define/public (get-parent) + parent) + + (define/public (get-eventspace) eventspace) + + (define is-on? #f) + (define/public (show on?) + (atomically + (unless (eq? (and on? #t) is-on?) + (if on? + (tellv (send parent get-cocoa-content) addSubview: cocoa) + (with-autorelease + (tellv cocoa removeFromSuperview))) + (set! is-on? (and on? #t)) + (maybe-register-as-child parent on?) + (if on? + (show-children) + (begin + (hide-children) + (is-responder this #f)))))) + (define/public (maybe-register-as-child parent on?) + ;; override this to call register-as-child if the window + ;; can have the focus or otherwise needs show-state notifications. + (void)) + (define/public (register-as-child parent on?) + (send parent register-child this on?)) + (define/public (register-child child on?) + (void)) + + (define/public (on-new-child child on?) + (if on? + (queue-window-event + child + (lambda () + (atomically + (with-autorelease + (send child child-accept-drag (or accept-drag? accept-parent-drag?)))))) + (send child child-accept-drag #f))) + + (define/public (is-shown?) + (and (tell cocoa superview) #t)) + + (define/public (is-shown-to-root?) + (and (is-shown?) + (send parent is-shown-to-root?))) + + (define/public (is-shown-to-before-root?) + (and (is-shown?) + (send parent is-shown-to-before-root?))) + + (define enabled? #t) + (define/public (is-enabled-to-root?) + (and (is-window-enabled?) (is-parent-enabled-to-root?))) + (define/public (is-parent-enabled-to-root?) + (send parent is-enabled-to-root?)) + (define/public (is-window-enabled?) + enabled?) + (define/public (enable on?) + (atomically + (set! enabled? on?) + (enable-window on?))) + (define/public (enable-window on?) + ;; in atomic mode + (void)) + + (define block-all-mouse-events? #f) + (define/public (block-mouse-events block?) + (set! block-all-mouse-events? block?)) + + (define/private (get-frame) + (let ([v (tell #:type _NSRect cocoa frame)]) + v)) + + (define/public (flip y h) + (if parent + (let ([b (tell #:type _NSRect (send parent get-cocoa-content) bounds)]) + (- (NSSize-height (NSRect-size b)) (+ y h))) + y)) + + (define/public (flip-client y) + (if (tell #:type _BOOL (get-cocoa-content) isFlipped) + y + (let ([r (tell #:type _NSRect (get-cocoa-content) bounds)]) + (- (NSSize-height (NSRect-size r)) + (- y (client-y-offset)))))) + (define/public (client-y-offset) 0) + + (define/public (is-view?) #t) + (define/public (window-point-to-view pos) + (let ([pos (if (is-view?) + (tell #:type _NSPoint (get-cocoa-content) + convertPoint: #:type _NSPoint pos + fromView: #f) + pos)]) + (values (NSPoint-x pos) + (flip-client (NSPoint-y pos))))) + + (define/public (get-x) + (->long (NSPoint-x (NSRect-origin (get-frame))))) + (define/public (get-y) + (let ([r (get-frame)]) + (->long (flip (NSPoint-y (NSRect-origin r)) + (NSSize-height (NSRect-size r)))))) + (define/public (get-width) + (->long (NSSize-width (NSRect-size (get-frame))))) + (define/public (get-height) + (->long (NSSize-height (NSRect-size (get-frame))))) + (define/public (get-position x y) + (let* ([r (get-frame)] + [p (NSRect-origin r)]) + (set-box! x (->long (NSPoint-x p))) + (set-box! y (->long (flip (NSPoint-y p) (NSSize-height (NSRect-size r))))))) + (define/public (get-size w h) + (let ([s (NSRect-size (get-frame))]) + (set-box! w (->long (NSSize-width s))) + (set-box! h (->long (NSSize-height s))))) + + (define/public (get-client-size w h) + ;; May be called in Cocoa event-handling mode + (let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))]) + (set-box! w (->long (NSSize-width s))) + (set-box! h (->long (NSSize-height s))))) + + (define/public (set-size x y w h) + (let ([x (if (= x -11111) (get-x) x)] + [y (if (= y -11111) (get-y) y)]) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) + (make-NSSize w h))))) + (define/public (internal-move x y) + (set-size x y (get-width) (get-height))) + (define/public (move x y) + (internal-move x y)) + + (define accept-drag? #f) + (define accept-parent-drag? #f) + + (define/public (on-drop-file f) (void)) + (define/public (do-on-drop-file f) + (if accept-drag? + (on-drop-file (string->path f)) + (when parent + (send parent do-on-drop-file f)))) + + (define/public (drag-accept-files on?) + (unless (eq? (and on? #t) accept-drag?) + (atomically + (with-autorelease + (set! accept-drag? (and on? #t)) + (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))))) + + (define/public (accept-drags-everywhere on?) + (if on? + (tellv (get-cocoa-content) registerForDraggedTypes: + (let ([a (tell NSArray arrayWithObjects: #:type (_list i _id) (list NSFilenamesPboardType) + count: #:type _NSUInteger 1)]) + a)) + (tellv (get-cocoa-content) unregisterDraggedTypes)) + (children-accept-drag on?)) + + (define/public (children-accept-drag on?) + (void)) + (define/public (child-accept-drag on?) + (unless (eq? (and on? #t) accept-parent-drag?) + (set! accept-parent-drag? (and on? #t)) + (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))) + + (define/public (set-focus) + (when (and (gets-focus?) + (is-enabled-to-root?)) + (let ([w (tell cocoa window)]) + (when w + (tellv w makeFirstResponder: (get-cocoa-content)))))) + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + + (define/public (definitely-wants-event? e) + ;; Called in Cocoa event-handling mode + #f) + + (define/private (pre-event-refresh key?) + ;; Since we break the connection between the + ;; Cocoa queue and event handling, we + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corresponding + ;; stream of screen updates. + (try-to-sync-refresh) + (flush)) + + (define/public (flush) + (let ([cocoa-win (get-cocoa-window)]) + (when cocoa-win + (tellv cocoa-win displayIfNeeded) + (tellv cocoa-win flushWindowIfNeeded)))) + + (define/public (dispatch-on-char/sync e) + (pre-event-refresh #t) + (dispatch-on-char e #f)) + (define/public (dispatch-on-char e just-pre?) + (cond + [(other-modal? this) #t] + [(call-pre-on-char this e) #t] + [just-pre? #f] + [else (when enabled? (on-char e)) #t])) + + (define/public (dispatch-on-event/sync e) + (pre-event-refresh #f) + (dispatch-on-event e #f)) + (define/public (dispatch-on-event e just-pre?) + (cond + [(other-modal? this) #t] + [(call-pre-on-event this e) #t] + [just-pre? block-all-mouse-events?] + [else (when enabled? (on-event e)) #t])) + + (define/public (call-pre-on-event w e) + (or (send parent call-pre-on-event w e) + (pre-on-event w e))) + (define/public (call-pre-on-char w e) + (or (send parent call-pre-on-char w e) + (pre-on-char w e))) + (define/public (pre-on-event w e) #f) + (define/public (pre-on-char w e) #f) + + (define/public (key-event-as-string s) + (dispatch-on-char (new key-event% + [key-code (string-ref s 0)] + [shift-down #f] + [control-down #f] + [meta-down #f] + [alt-down #f] + [x 0] + [y 0] + [time-stamp (current-milliseconds)] ; FIXME + [caps-down #f]) + #f)) + + (define/public (on-char s) (void)) + (define/public (on-event m) (void)) + (define/public (on-size x y) (void)) + + (define last-l? #f) + (define last-m? #f) + (define last-r? #f) + (define/public (set-last-buttons l? m? r?) + (set! last-l? l?) + (set! last-m? m?) + (set! last-r? r?)) + (define/public (get-last-left-button) last-l?) + (define/public (get-last-middle-button) last-m?) + (define/public (get-last-right-button) last-r?) + + (define/public (set-sticky-cursor) + (set! sticky-cursor? #t)) + + (define/public (start-no-cursor-rects) + (send (get-parent) start-no-cursor-rects)) + (define/public (end-no-cursor-rects) + (set! sticky-cursor? #f) + (send (get-parent) end-no-cursor-rects)) + + (define/public (get-handle) (get-cocoa)) + + (define/public (popup-menu m x y) + (send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y) + (lambda (thunk) + (queue-window-event this thunk)))) + + (define/public (center a b) (void)) + (define/public (refresh) (void)) + + (define/public (screen-to-client xb yb) + (let ([p (tell #:type _NSPoint (get-cocoa-content) + convertPoint: #:type _NSPoint + (tell #:type _NSPoint (get-cocoa-window) + convertScreenToBase: + #:type _NSPoint (make-NSPoint (unbox xb) + (send (get-wx-window) flip-screen (unbox yb)))) + fromView: #f)]) + (set-box! xb (inexact->exact (floor (NSPoint-x p)))) + (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) + + (define/public (client-to-screen xb yb [flip-y? #t]) + (let* ([p (tell #:type _NSPoint (get-cocoa-window) + convertBaseToScreen: + #:type _NSPoint + (tell #:type _NSPoint (get-cocoa-content) + convertPoint: #:type _NSPoint + (make-NSPoint (unbox xb) (flip-client (unbox yb))) + toView: #f))]) + (let ([new-y (if flip-y? + (send (get-wx-window) flip-screen (NSPoint-y p)) + (NSPoint-y p))]) + (set-box! xb (inexact->exact (floor (NSPoint-x p)))) + (set-box! yb (inexact->exact (floor new-y)))))) + + (define cursor-handle #f) + (define sticky-cursor? #f) + (define/public (set-cursor c) + (let ([h (if c + (send (send c get-driver) get-handle) + #f)]) + (unless (eq? h cursor-handle) + (atomically + (set! cursor-handle h) + (when sticky-cursor? (tellv h set)) + (tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content)))))) + (define/public (reset-cursor-rects) + ;; called in event-pump thread + (when cursor-handle + (let ([content (get-cocoa-cursor-content)]) + (let* ([r (tell #:type _NSRect content frame)] + [r (make-NSRect (make-NSPoint 0 0) + (make-NSSize + (- (NSSize-width (NSRect-size r)) + (get-cursor-width-delta)) + (NSSize-height (NSRect-size r))))]) + (tellv content addCursorRect: #:type _NSRect r cursor: cursor-handle))))) + (define/public (get-cursor-width-delta) 0) + + (define/public (gets-focus?) #f) + (define/public (can-be-responder?) (is-enabled-to-root?)) + + (define/public (on-color-change) + (send parent on-color-change)) + + ;; For multi-key character composition: + (define saved-marked #f) + (define/public (set-saved-marked v) (set! saved-marked v)) + (define/public (get-saved-marked) saved-marked))) + +;; ---------------------------------------- + +(define (queue-window-event wx thunk) + (queue-event (send wx get-eventspace) thunk)) + +(define (queue-window-refresh-event wx thunk) + (queue-refresh-event (send wx get-eventspace) thunk)) + +(define (queue-window*-event wxb proc) + (let ([wx (->wx wxb)]) + (when wx + (queue-event (send wx get-eventspace) (lambda () (proc wx)))))) + +(define (request-flush-delay cocoa-win) + (do-request-flush-delay + cocoa-win + (lambda (cocoa-win) + (tellv cocoa-win disableFlushWindow) + #t) + (lambda (cocoa-win) + (tellv cocoa-win enableFlushWindow)))) + +(define (cancel-flush-delay req) + (do-cancel-flush-delay + req + (lambda (cocoa-win) + (tellv cocoa-win enableFlushWindow)))) + +(define (make-init-point x y) + (make-NSPoint (if (= x -11111) + 0 + x) + (if (= y -11111) + 0 + y))) + +(define (flush-display) + (try-to-sync-refresh) + (for ([win (in-list (get-top-level-windows))]) + (send win flush))) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt new file mode 100644 index 00000000..f6c9b3b5 --- /dev/null +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -0,0 +1,157 @@ +#lang racket/base +(require racket/class + racket/draw/private/dc + racket/draw/private/bitmap-dc + racket/draw/private/bitmap + racket/draw/private/local + "../../lock.rkt" + "queue.rkt") + +(provide + (protect-out backing-dc% + + ;; scoped method names: + get-backing-size + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained + make-backing-bitmap + request-delay + cancel-delay + end-delay)) + +(define-local-member-name + get-backing-size + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained + make-backing-bitmap + request-delay + cancel-delay + end-delay) + +(define backing-dc% + (class (dc-mixin bitmap-dc-backend%) + (inherit internal-get-bitmap + internal-set-bitmap + reset-cr) + + (super-new) + + (define/override (ok?) #t) + + ;; Override this method to get the right size + (define/public (get-backing-size xb yb) + (set-box! xb 1) + (set-box! yb 1)) + + ;; override this method to set up a callback to + ;; `on-backing-flush' when the backing store can be rendered + ;; to the screen; called atomically (expecting no exceptions) + (define/public (queue-backing-flush) + (void)) + + (define retained-cr #f) + (define retained-counter 0) + (define needs-flush? #f) + (define nada? #t) + + ;; called with a procedure that is applied to a bitmap; + ;; returns #f if there's nothing to flush + (define/public (on-backing-flush proc) + (cond + [(not retained-cr) #f] + [(positive? retained-counter) + (unless nada? + (proc (internal-get-bitmap))) + #t] + [else + (reset-backing-retained proc) + #t])) + + (define/public (can-backing-flush?) + (and retained-cr #t)) + + (define/public (reset-backing-retained [proc void]) + (let ([cr retained-cr]) + (when cr + (let ([bm (internal-get-bitmap)]) + (set! retained-cr #f) + (internal-set-bitmap #f #t) + (super release-cr retained-cr) + (proc bm) + (release-backing-bitmap bm))))) + + (define/public (start-backing-retained) + (as-entry + (lambda () + (set! retained-counter (add1 retained-counter))))) + + (define/public (end-backing-retained) + (as-entry + (lambda () + (if (zero? retained-counter) + (log-error "unbalanced end-on-paint") + (set! retained-counter (sub1 retained-counter)))))) + + (define/public (make-backing-bitmap w h) + (make-object bitmap% w h #f #t)) + + (define/public (ensure-ready) (get-cr)) + + (define/override (get-cr) + (or retained-cr + (let ([w (box 0)] + [h (box 0)]) + (get-backing-size w h) + (let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap w h)) (unbox w) (unbox h))]) + (internal-set-bitmap bm #t)) + (let ([cr (super get-cr)]) + (set! retained-cr cr) + (reset-cr cr) + cr)))) + + (define/override (release-cr cr) + (set! nada? #f) + (when (zero? flush-suspends) + (queue-backing-flush))) + + (define/override (erase) + (super erase) + (set! nada? #t)) + + (define flush-suspends 0) + (define req #f) + + (define/public (request-delay) (void)) + (define/public (cancel-delay req) (void)) + + (define/override (suspend-flush) + (atomically + (when (zero? flush-suspends) + (when req (cancel-delay req)) + (set! req (request-delay))) + (set! flush-suspends (add1 flush-suspends)))) + + (define/override (resume-flush) + (atomically + (unless (zero? flush-suspends) + (set! flush-suspends (sub1 flush-suspends)) + (when (zero? flush-suspends) + (queue-backing-flush))))) + + (define/public (end-delay) + ;; call in atomic mode + (when (and (zero? flush-suspends) req) + (cancel-delay req) + (set! req #f))))) + +(define (get-backing-bitmap make-bitmap w h) + (make-bitmap w h)) + +(define (release-backing-bitmap bm) + (send bm release-bitmap-storage)) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt new file mode 100644 index 00000000..07c4364f --- /dev/null +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -0,0 +1,200 @@ +#lang racket/base +(require racket/class + racket/draw + "../common/queue.rkt" + "backing-dc.rkt") + +(provide + (protect-out canvas-autoscroll-mixin + canvas-mixin + fix-bitmap-size)) + +;; Implements canvas autoscroll, applied *before* platform-specific canvas +;; methods: +(define (canvas-autoscroll-mixin %) + (class % + (super-new) + + (inherit get-client-size + refresh) + + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) + + (define/public (is-auto-scroll?) auto-scroll?) + (define/public (get-virtual-height) virtual-height) + (define/public (get-virtual-width) virtual-width) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) h-len)) + (set! virtual-height (and (positive? v-len) v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (let ([a? auto-scroll?]) + (set! auto-scroll? #f) + (set! virtual-width #f) + (set! virtual-height #f) + (when a? (reset-dc-for-autoscroll))) ; disable scroll offsets + (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos)])) + + ;; To be overridden: + (define/public (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (void)) + + (define/public (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (do-set-scrollbars 1 1 + h-len v-len + h-page v-page + h-pos v-pos))))) + + ;; To be overridden: + (define/public (reset-dc-for-autoscroll) + (void)) + + (define/public (refresh-for-autoscroll) + (reset-dc-for-autoscroll) + (refresh)) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (get-virtual-h-pos) + 0)) + (set-box! yb (if virtual-height + (get-virtual-v-pos) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + + ;; To be overridden: + (define/public (get-virtual-h-pos) 0) + (define/public (get-virtual-v-pos) 0) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))))) + +;; Implements canvas refresh, applied *after* platform-specific canvas +;; methods: +(define (canvas-mixin %) + (class % + (super-new) + + (inherit request-canvas-flush-delay + cancel-canvas-flush-delay + queue-canvas-refresh-event + is-shown-to-root? + on-paint + queue-backing-flush + get-dc + get-canvas-background-for-backing) + + ;; Avoid multiple queued paints, and also allow cancel + ;; of queued paint: + (define paint-queued #f) ; #f or (box #t) + + (define/override (queue-paint) + ;; can be called from any thread, including the event-pump thread + (unless paint-queued + (let ([b (box #t)]) + (set! paint-queued b) + (let ([req (request-canvas-flush-delay)]) + (queue-canvas-refresh-event + (lambda () (do-on-paint req b))))))) + + (define/private (do-on-paint req b) + ;; only called in the handler thread + (when (or (not b) (unbox b)) + (let ([pq paint-queued]) + (when pq (set-box! pq #f))) + (set! paint-queued #f) + (when (or (not b) (is-shown-to-root?)) + (let ([dc (get-dc)]) + (send dc suspend-flush) + (send dc ensure-ready) + (send dc erase) ; start with a clean slate + (let ([bg (get-canvas-background-for-backing)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (send dc resume-flush) + (queue-backing-flush)))) + (when req + (cancel-canvas-flush-delay req))) + + (define/override (paint-children) + (when (or paint-queued + (not (send (get-dc) can-backing-flush?))) + (do-on-paint #f #f))) + + + (define flush-box #f) + + ;; Periodic flush is needed for Windows, where + ;; updates otherwise happen only via the eventspace's queue + (define/override (schedule-periodic-backing-flush) + (unless flush-box + (set! flush-box (box #t)) + (add-event-boundary-sometimes-callback! + flush-box + (lambda (b) + (when (unbox b) + (do-canvas-backing-flush #f)))))) + + (define/override (do-canvas-backing-flush ctx) + ;; cancel scheduled flush, if any: + (when flush-box + (set-box! flush-box #f) + (set! flush-box #f)) + (super do-canvas-backing-flush ctx)))) + +;; useful for fixing the size of a collecting blit: +(define (fix-bitmap-size on w h on-x on-y) + (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm)))) diff --git a/collects/mred/private/wx/common/clipboard.rkt b/collects/mred/private/wx/common/clipboard.rkt new file mode 100644 index 00000000..383394fd --- /dev/null +++ b/collects/mred/private/wx/common/clipboard.rkt @@ -0,0 +1,79 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt" + "../platform.rkt" + "local.rkt" + "queue.rkt") + +(provide + (protect-out clipboard<%> + clipboard-client% + get-the-clipboard + get-the-x-selection)) + +(defclass clipboard-client% object% + (define types null) + (define es (current-eventspace)) + (define/public (get-client-eventspace) es) + (define/public (set-client-eventspace e) (set! es e)) + (def/public (same-eventspace? [eventspace? e]) + (eq? e es)) + (def/public (get-types) + types) + (def/public (add-type [string? str]) + (set! types (cons (string->immutable-string str) types))) + (def/public (get-data [string? format]) + #f) + (def/public (on-replaced) + (void)) + (super-new)) + +(define string-clipboard-client% + (class clipboard-client% + (init-field the-bytes) + (super-new) + (define/override (get-types) (list "TEXT")) + (define/override (get-data s) + (and (equal? s "TEXT") the-bytes)))) + +(defclass clipboard% object% + (init x-selection?) + + (define driver (new clipboard-driver% + [x-selection? x-selection?])) + + (def/public (same-clipboard-client? [clipboard-client% c]) + (eq? c (send driver get-client))) + + (def/public (get-clipboard-bitmap [exact-integer? timestamp]) + (send driver get-bitmap-data)) + (def/public-unimplemented set-clipboard-bitmap) + (def/public (get-clipboard-data [string? type] + [exact-integer? timestamp]) + (send driver get-data type)) + (def/public (get-clipboard-string [exact-integer? timestamp]) + (send driver get-text-data)) + (def/public (set-clipboard-client [clipboard-client% c] + [exact-integer? timestamp]) + (send c set-client-eventspace (current-eventspace)) + (send driver set-client c (send c get-types))) + (def/public (set-clipboard-string [string? str] + [exact-integer? timestamp]) + (set-clipboard-client (make-object string-clipboard-client% + (string->bytes/utf-8 str)) + timestamp)) + + (super-new)) + +(define clipboard<%> (class->interface clipboard%)) + +(define the-clipboard (new clipboard% [x-selection? #f])) +(define the-x-selection + (if has-x-selection? + (new clipboard% [x-selection? #t]) + the-clipboard)) + +(define (get-the-clipboard) + the-clipboard) +(define (get-the-x-selection) + the-x-selection) diff --git a/collects/mred/private/wx/common/cursor-draw.rkt b/collects/mred/private/wx/common/cursor-draw.rkt new file mode 100644 index 00000000..78149554 --- /dev/null +++ b/collects/mred/private/wx/common/cursor-draw.rkt @@ -0,0 +1,61 @@ +#lang racket/base +(require racket/class + racket/draw) + +(provide make-cursor-image + draw-watch + draw-nw/se + draw-ne/sw + draw-bullseye) + +(define (make-cursor-image draw-proc [smoothing 'aligned]) + (let* ([bm (make-object bitmap% 16 16 #f #t)] + [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing smoothing) + (draw-proc dc 16 16) + (send dc set-bitmap #f) + bm)) + +(define (draw-watch dc w h) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 5 0 6 4) + (send dc draw-rectangle 5 12 6 4) + (send dc set-brush "white" 'solid) + (send dc draw-ellipse 3 3 10 10) + (send dc draw-line 7 5 7 8) + (send dc draw-line 7 8 9 8)) + +(define (draw-nw/se dc w h) + (bolden + dc + (lambda () + (send dc set-smoothing 'unsmoothed) + (send dc draw-line 0 16 16 0) + (send dc draw-line 0 0 16 16) + (send dc draw-line 1 4 1 1) + (send dc draw-line 1 1 4 1) + (send dc draw-line 12 15 15 15) + (send dc draw-line 15 15 15 12)))) + +(define (draw-ne/sw dc w h) + (bolden + dc + (lambda () + (send dc set-smoothing 'unsmoothed) + (send dc draw-line 0 16 16 0) + (send dc draw-line 0 0 16 16) + (send dc draw-line 12 1 15 1) + (send dc draw-line 15 1 15 4) + (send dc draw-line 1 12 1 15) + (send dc draw-line 1 15 4 15)))) + +(define (draw-bullseye dc w h) + (send dc draw-ellipse 1 1 (- w 2) (- h 2)) + (send dc draw-ellipse 4 4 (- w 8) (- h 8)) + (send dc draw-ellipse 7 7 2 2)) + +(define (bolden dc draw) + (send dc set-pen "white" 4 'solid) + (draw) + (send dc set-pen "black" 2 'solid) + (draw)) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt new file mode 100644 index 00000000..f8aa09ac --- /dev/null +++ b/collects/mred/private/wx/common/cursor.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require racket/class + racket/draw + "local.rkt" + (only-in "../platform.rkt" cursor-driver%) + "../../syntax.rkt") + +(provide cursor%) + +(define standards (make-hash)) + +(define (is-16x16? image) + (and (not (send image is-color?)) + (= 16 (send image get-width)) + (= 16 (send image get-height)))) + +(defclass cursor% object% + + (init-rest args) + (define driver + (case-args + args + [([(symbol-in arrow bullseye cross hand ibeam watch blank + size-n/s size-e/w size-ne/sw size-nw/se + arrow+watch) + sym]) + (or (hash-ref standards sym #f) + (let ([c (new cursor-driver%)]) + (send c set-standard sym) + (hash-set! standards sym c) + c))] + [([bitmap% image] + [bitmap% mask] + [(integer-in 0 15) [hot-spot-x 0]] + [(integer-in 0 15) [hot-spot-y 0]]) + (unless (is-16x16? image) + (raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| image)) + (unless (is-16x16? mask) + (raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| mask)) + (let ([c (new cursor-driver%)]) + (send c set-image image mask hot-spot-x hot-spot-y) + c)] + (init-name 'cursor%))) + + (define/public (get-driver) driver) + + (def/public (ok?) (send driver ok?)) + (super-new)) diff --git a/collects/mred/private/wx/common/default-procs.rkt b/collects/mred/private/wx/common/default-procs.rkt new file mode 100644 index 00000000..52598374 --- /dev/null +++ b/collects/mred/private/wx/common/default-procs.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require racket/class + racket/draw/private/color) +(provide special-control-key + special-option-key + file-creator-and-type + get-panel-background + fill-private-color) + +(define special-control-key? #f) +(define special-control-key + (case-lambda + [() special-control-key?] + [(on?) (set! special-control-key? (and on? #t))])) + +(define special-option-key? #f) +(define special-option-key + (case-lambda + [() special-option-key?] + [(on?) (set! special-option-key? (and on? #t))])) + +(define file-creator-and-type + (case-lambda + [(path cr ty) (void)] + [(path) (values #"????" #"????")])) + +(define (get-panel-background) + (make-object color% "gray")) + +(define (fill-private-color dc col) + (send dc set-background col) + (send dc clear)) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt new file mode 100644 index 00000000..ef8d7044 --- /dev/null +++ b/collects/mred/private/wx/common/delay.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require "../../lock.rkt" + "queue.rkt") + +(provide + (protect-out do-request-flush-delay + do-cancel-flush-delay)) + +;; Auto-cancel schedules a cancel of a request flush +;; on event boundaries. It makes sense if you don't +;; trust a program to un-delay important refreshes, +;; but auto-cancel is currently disabled because +;; bad refresh-delay effects are confined to the enclosing +;; window on all platforms. +(define AUTO-CANCEL-DELAY? #f) + +(define (do-request-flush-delay win disable enable) + (atomically + (let ([req (box win)]) + (and + (disable win) + (begin + (when AUTO-CANCEL-DELAY? + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win))))) + req))))) + +(define (do-cancel-flush-delay req enable) + (atomically + (let ([win (unbox req)]) + (when win + (set-box! req #f) + (enable win) + (when AUTO-CANCEL-DELAY? + (remove-event-boundary-callback! req)))))) diff --git a/collects/mred/private/wx/common/dialog.rkt b/collects/mred/private/wx/common/dialog.rkt new file mode 100644 index 00000000..319b265f --- /dev/null +++ b/collects/mred/private/wx/common/dialog.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require racket/class + "../../lock.rkt" + "queue.rkt") + +(provide (protect-out dialog-mixin)) + +(define dialog-level-counter 0) + +(define (dialog-mixin %) + (class % + (super-new) + + (define close-sema #f) + + (define dialog-level 0) + (define/override (get-dialog-level) dialog-level) + + (define/override (frame-relative-dialog-status win) + (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))) + + (define/override (direct-show on?) + ;; atomic mode + (when on? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (unless on? + (set! dialog-level 0)) + (unless on? + (when close-sema + (semaphore-post close-sema) + (set! close-sema #f))) + (super direct-show on?)) + + (define/override (show on?) + (if on? + (let ([s (atomically + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + (semaphore-peek-evt s)))]) + (super show on?) + (yield s) + (void)) + (super show on?))))) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt new file mode 100644 index 00000000..88f1fc5f --- /dev/null +++ b/collects/mred/private/wx/common/event.rkt @@ -0,0 +1,111 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt") + +(provide event% + mouse-event% + key-event% + control-event% + scroll-event% + popup-event%) + +(defclass event% object% + (init-properties [[exact-integer? time-stamp] 0]) + (super-new)) + +(defclass mouse-event% event% + (init-properties [[(symbol-in enter leave left-down left-up + middle-down middle-up + right-down right-up motion) + event-type]] + [[bool? left-down] #f] + [[bool? middle-down] #f] + [[bool? right-down] #f] + [[exact-integer? x] 0] + [[exact-integer? y] 0] + [[bool? shift-down] #f] + [[bool? control-down] #f] + [[bool? meta-down] #f] + [[bool? alt-down] #f]) + (init [time-stamp 0]) + (init-properties [[bool? caps-down] #f]) + (super-new [time-stamp time-stamp]) + + (def/public (button-changed? [(symbol-in left middle right any) [button 'any]]) + (and (memq event-type + (case button + [(any) '(left-down left-up middle-down middle-up right-down right-up)] + [(left) '(left-down left-up)] + [(middle) '(middle-down middle-up)] + [(right) '(right-down right-up)])) + #t)) + + (def/public (button-down? [(symbol-in left middle right any) [button 'any]]) + (and (memq event-type + (case button + [(any) '(left-down middle-down right-down)] + [(left) '(left-down)] + [(middle) '(middle-down)] + [(right) '(right-down)])) + #t)) + + (def/public (button-up? [(symbol-in left middle right any) [button 'any]]) + (and (memq event-type + (case button + [(any) '(left-up middle-up right-up)] + [(left) '(left-up)] + [(middle) '(middle-up)] + [(right) '(right-up)])) + #t)) + + (def/public (dragging?) + (and (eq? event-type 'motion) + (or left-down middle-down right-down))) + + (def/public (entering?) + (eq? event-type 'enter)) + + (def/public (leaving?) + (eq? event-type 'leave)) + + (def/public (moving?) + (eq? event-type 'motion))) + +(defclass key-event% event% + (init-properties [[(make-alts symbol? char?) key-code] #\nul] + [[bool? shift-down] #f] + [[bool? control-down] #f] + [[bool? meta-down] #f] + [[bool? alt-down] #f] + [[exact-integer? x] 0] + [[exact-integer? y] 0]) + (init [time-stamp 0]) + (init-properties [[bool? caps-down] #f]) + (properties [[(make-alts symbol? char?) key-release-code] 'down] + [[(make-or-false (make-alts symbol? char?)) other-shift-key-code] #f] + [[(make-or-false (make-alts symbol? char?)) other-altgr-key-code] #f] + [[(make-or-false (make-alts symbol? char?)) other-shift-altgr-key-code] #f] + [[(make-or-false (make-alts symbol? char?)) other-caps-key-code] #f]) + (super-new [time-stamp time-stamp])) + +(defclass control-event% event% + (init-properties [[(symbol-in button check-box choice + list-box list-box-dclick text-field + text-field-enter slider radio-box + menu-popdown menu-popdown-none tab-panel) + event-type]]) + (init [time-stamp 0]) + (super-new [time-stamp time-stamp])) + +(defclass popup-event% control-event% + (properties [[any? menu-id] 0]) + (super-new)) + +(defclass scroll-event% event% + (init-properties [[(symbol-in top bottom line-up line-down page-up page-down thumb) event-type] + 'thumb] + [[(symbol-in horizontal vertical) direction] 'vertical] + [[(integer-in 0 10000) position] 0]) + (init [time-stamp 0]) + (super-new [time-stamp time-stamp])) + diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt new file mode 100644 index 00000000..7ee55836 --- /dev/null +++ b/collects/mred/private/wx/common/freeze.rkt @@ -0,0 +1,49 @@ +#lang racket/base +(require ffi/unsafe/try-atomic + "queue.rkt") + +(provide + call-as-nonatomic-retry-point + (protect-out constrained-reply)) + +(define (internal-error str) + (log-error + (apply string-append + (format "internal error: ~a" str) + (append + (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) + (let ([name (car c)] + [loc (cdr c)]) + (cond + [loc + (string-append + "\n" + (cond + [(srcloc-line loc) + (format "~a:~a:~a" + (srcloc-source loc) + (srcloc-line loc) + (srcloc-column loc))] + [else + (format "~a::~a" + (srcloc-source loc) + (srcloc-position loc))]) + (if name (format " ~a" name) ""))] + [else (format "\n ~a" name)]))) + '("\n"))))) + +;; FIXME: waiting 200msec is not a good enough rule. +(define (constrained-reply es thunk default + #:fail-result [fail-result default]) + (cond + [(not (can-try-atomic?)) + ;; Ideally, this would count as an error that we can fix. It seems that we + ;; don't always have enough control to use the right eventspace with a + ;; retry point, though, so just bail out with the default. + #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) + fail-result] + [(not (eq? (current-thread) (eventspace-handler-thread es))) + (internal-error "wrong eventspace for constrained event handling\n") + fail-result] + [else + (try-atomic thunk default)])) diff --git a/collects/mred/private/wx/common/handlers.rkt b/collects/mred/private/wx/common/handlers.rkt new file mode 100644 index 00000000..3776fd01 --- /dev/null +++ b/collects/mred/private/wx/common/handlers.rkt @@ -0,0 +1,40 @@ +#lang racket/base + +(provide + (protect-out application-file-handler + application-quit-handler + application-about-handler + application-pref-handler + + nothing-application-pref-handler)) + +(define saved-files null) +(define afh (lambda (f) + (set! saved-files (cons f saved-files)))) +(define application-file-handler + (case-lambda + [(proc) + (set! afh proc) + (let ([sf saved-files]) + (set! saved-files null) + (for-each proc (reverse sf)))] + [() afh])) + +(define aqh void) +(define application-quit-handler + (case-lambda + [(proc) (set! aqh proc)] + [() aqh])) + +(define aah void) +(define application-about-handler + (case-lambda + [(proc) (set! aah proc)] + [() aah])) + +(define (nothing-application-pref-handler) (void)) +(define aph nothing-application-pref-handler) +(define application-pref-handler + (case-lambda + [(proc) (set! aph proc)] + [() aph])) diff --git a/collects/mred/private/wx/common/local.rkt b/collects/mred/private/wx/common/local.rkt new file mode 100644 index 00000000..82a8c6b6 --- /dev/null +++ b/collects/mred/private/wx/common/local.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require racket/class) + +(provide (protect-out (all-defined-out))) + +(define-local-member-name + ;; clipboard-client%: + get-client-eventspace + set-client-eventspace + + ;; cursor% + get-driver) + diff --git a/collects/mred/private/wx/common/once.rkt b/collects/mred/private/wx/common/once.rkt new file mode 100644 index 00000000..d4167541 --- /dev/null +++ b/collects/mred/private/wx/common/once.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require ffi/unsafe) + +(provide (protect-out scheme_register_process_global)) + +;; This module must be instantiated only once: + +(define scheme_register_process_global + (get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer))) + +(let ([v (scheme_register_process_global "GRacket-support-initialized" + (cast 1 _scheme _pointer))]) + (when v + (error "cannot instantiate `racket/gui/base' a second time in the same process"))) diff --git a/collects/mred/private/wx/common/procs.rkt b/collects/mred/private/wx/common/procs.rkt new file mode 100644 index 00000000..6434cc48 --- /dev/null +++ b/collects/mred/private/wx/common/procs.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "../../syntax.rkt") + +(provide + label->plain-label) + +(define/top (label->plain-label [string? s]) + (regexp-replace* #rx"&(.)" + (regexp-replace + #rx"[(]&(.)[)] *" + (regexp-replace #rx"\t.*$" s "") + "\\1") + "\\1")) + diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt new file mode 100644 index 00000000..010211ef --- /dev/null +++ b/collects/mred/private/wx/common/queue.rkt @@ -0,0 +1,526 @@ +#lang racket/base +(require ffi/unsafe + racket/draw/private/utils + ffi/unsafe/atomic + racket/class + "rbtree.rkt" + "../../lock.rkt" + "handlers.rkt" + "once.rkt") + +(provide + (protect-out queue-evt + set-check-queue! + set-queue-wakeup! + + add-event-boundary-callback! + add-event-boundary-sometimes-callback! + remove-event-boundary-callback! + pre-event-sync + boundary-tasks-ready-evt + sometimes-delay-msec + + eventspace? + current-eventspace + queue-event + queue-refresh-event + yield + yield-refresh + (rename-out [make-new-eventspace make-eventspace]) + + event-dispatch-handler + eventspace-shutdown? + main-eventspace? + eventspace-handler-thread + eventspace-wait-cursor-count + eventspace-extra-table + eventspace-adjust-external-modal! + + queue-callback + middle-queue-key + + make-timer-callback + add-timer-callback + remove-timer-callback + + register-frame-shown + get-top-level-windows + other-modal? + + queue-quit-event + queue-prefs-event + queue-file-event + + begin-busy-cursor + end-busy-cursor + is-busy?) + + scheme_register_process_global) + +;; ------------------------------------------------------------ +;; Create a Scheme evt that is ready when a queue is nonempty + +(define _Scheme_Type _short) +(define-mz scheme_make_type (_fun _string -> _Scheme_Type)) +(define event-queue-type (scheme_make_type "event-queue")) + +(define-mz scheme_add_evt (_fun _Scheme_Type + (_fun #:atomic? #t _scheme -> _int) + (_fun #:atomic? #t _scheme _pointer -> _void) + _pointer + _int + -> _void)) + +(define (do-check-queue) #f) +(define (do-queue-wakeup fds) #f) + +(define (check-queue o) + (if (do-check-queue) 1 0)) +(define (queue-wakeup o fds) + (do-queue-wakeup fds)) +(scheme_add_evt event-queue-type check-queue queue-wakeup #f 0) +(define queue-evt (let ([p (malloc 16)] + [p2 (malloc 'nonatomic _pointer)]) + (memset p 0 16) + (ptr-set! p _Scheme_Type event-queue-type) + (ptr-set! p2 _pointer p) + (ptr-ref p2 _scheme))) + +(define (set-check-queue! check) + (set! do-check-queue check)) +(define (set-queue-wakeup! wake) + (set! do-queue-wakeup wake)) + +;; ------------------------------------------------------------ +;; Pre-event sync + +(define boundary-ht (make-hasheq)) +(define sometimes-boundary-ht (make-hasheq)) + +(define tasks-ready? #f) +(define task-ready-sema (make-semaphore)) +(define boundary-tasks-ready-evt (semaphore-peek-evt task-ready-sema)) + +(define (alert-tasks-ready) + (let ([ready? (or (positive? (hash-count boundary-ht)) + (positive? (hash-count sometimes-boundary-ht)))]) + (unless (eq? ready? tasks-ready?) + (set! tasks-ready? ready?) + (if ready? + (semaphore-post task-ready-sema) + (semaphore-wait task-ready-sema))))) + +(define (add-event-boundary-callback! v proc) + (atomically + (hash-set! boundary-ht v proc) + (alert-tasks-ready))) +(define (add-event-boundary-sometimes-callback! v proc) + (atomically + (when (zero? (hash-count sometimes-boundary-ht)) + (set! last-time (current-inexact-milliseconds))) + (hash-set! sometimes-boundary-ht v proc) + (alert-tasks-ready))) + +(define (remove-event-boundary-callback! v) + (atomically + (hash-remove! boundary-ht v) + (hash-remove! sometimes-boundary-ht v) + (alert-tasks-ready))) + +(define last-time -inf.0) +(define sometimes-delay-msec 100) + +;; Call this function only in atomic mode: +(define (pre-event-sync force?) + (let ([now (current-inexact-milliseconds)]) + (when (or (now . > . (+ last-time sometimes-delay-msec)) + force?) + (set! last-time now) + (hash-for-each sometimes-boundary-ht + (lambda (v p) (hash-remove! sometimes-boundary-ht v) (p v))))) + (hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v))) + (alert-tasks-ready)) + +;; ------------------------------------------------------------ +;; Eventspaces + +(define-struct eventspace (handler-thread + queue-proc + frames-hash + done-evt + [shutdown? #:mutable] + done-sema + [wait-cursor-count #:mutable] + extra-table + [external-modal #:mutable]) + #:property prop:evt (lambda (v) + (wrap-evt (eventspace-done-evt v) + (lambda (_) v)))) +(define-struct timed (alarm-evt msecs val [id #:mutable])) + +(define (make-timer-callback msecs thunk) + (make-timed (alarm-evt msecs) + msecs + thunk + 0)) + +(define (timed-compare a b) + (if (eq? a b) + 0 + (let ([am (timed-msecs a)] + [bm (timed-msecs b)]) + (cond + [(= am bm) (if ((timed-id a) . < . (timed-id b)) + -1 + 1)] + [(< am bm) -1] + [else 1])))) + +;; This table refers to handle threads of eventspaces +;; that have an open window, etc., so that the eventspace +;; isn't GCed +(define active-eventspaces (make-hasheq)) + +(define current-cb-box (make-parameter #f)) + +(define-mz scheme_add_managed (_fun _racket ; custodian + _racket ; object + (_fun #:atomic? #t #:keep (lambda (v) (set-box! (current-cb-box) v)) + _racket _racket -> _void) + _racket ; data + _int ; strong? + -> _pointer)) + +(define (shutdown-eventspace! e ignored) + ;; atomic mode + (unless (eventspace-shutdown? e) + (set-eventspace-shutdown?! e #t) + (semaphore-post (eventspace-done-sema e)) + (for ([f (in-list (get-top-level-windows e))]) + (send f destroy)) + (hash-remove! active-eventspaces (eventspace-handler-thread e)))) + +(define (make-eventspace* th) + (let ([done-sema (make-semaphore 1)] + [done-set? #t] + [frames (make-hasheq)]) + (let ([e + (make-eventspace th + (let ([count 0]) + (let ([lo (mcons #f #f)] + [refresh (mcons #f #f)] + [med (mcons #f #f)] + [hi (mcons #f #f)] + [timer (box '())] + [timer-counter 0] + [newly-posted-sema (make-semaphore)]) + (let* ([check-done + (lambda () + (if (or (positive? count) + (positive? (hash-count frames)) + (not (null? (unbox timer)))) + (when done-set? + (hash-set! active-eventspaces th #t) + (set! done-set? #f) + (semaphore-try-wait? done-sema)) + (unless done-set? + (hash-remove! active-eventspaces th) + (set! done-set? #t) + (semaphore-post done-sema))))] + [enqueue (lambda (v q) + (set! count (add1 count)) + (check-done) + (let ([p (mcons v #f)]) + (if (mcdr q) + (set-mcdr! (mcdr q) p) + (set-mcar! q p)) + (set-mcdr! q p)))] + [first (lambda (q) + (and (mcar q) + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (set! count (sub1 count)) + (check-done) + (let ([result (mcar (mcar q))]) + (set-mcar! q (mcdr (mcar q))) + (unless (mcar q) + (set-mcdr! q #f)) + (end-atomic) + result)))))] + [remove-timer + (lambda (v timer) + (set-box! timer (rbtree-remove + timed-compare + v + (unbox timer))) + (check-done))]) + (case-lambda + [(v) + ;; Enqueue + (start-atomic) + (let ([val (cdr v)]) + (case (car v) + [(lo) (enqueue val lo)] + [(refresh) (enqueue val refresh)] + [(med) (enqueue val med)] + [(hi) (enqueue val hi)] + [(timer-add) + (set! timer-counter (add1 timer-counter)) + (set-timed-id! val timer-counter) + (set-box! timer + (rbtree-insert + timed-compare + val + (unbox timer))) + (check-done)] + [(timer-remove) (remove-timer val timer)] + [(frame-add) (hash-set! frames val #t) (check-done)] + [(frame-remove) (hash-remove! frames val) (check-done)])) + (semaphore-post newly-posted-sema) + (set! newly-posted-sema (make-semaphore)) + (check-done) + (end-atomic)] + [() + ;; Dequeue as evt + (start-atomic) + (let ([timer-first-ready + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) + (let* ([v (rbtree-min (unbox timer))] + [evt (timed-alarm-evt v)]) + (and (sync/timeout 0 evt) + ;; It's ready + (wrap-evt + always-evt + (lambda (_) + (start-atomic) + (remove-timer v timer) + (end-atomic) + (timed-val v))))))))] + [timer-first-wait + (lambda (timer) + (let ([rb (unbox timer)]) + (and (not (null? rb)) + (wrap-evt + (timed-alarm-evt (rbtree-min (unbox timer))) + (lambda (_) #f)))))]) + (let ([e (choice-evt + (wrap-evt (semaphore-peek-evt newly-posted-sema) + (lambda (_) #f)) + (or (first hi) + (timer-first-ready timer) + (first refresh) + (first med) + (first lo) + (timer-first-wait timer) + ;; nothing else ready... + never-evt))]) + (end-atomic) + e))] + [(_1 _2) + ;; Dequeue only refresh event + (start-atomic) + (begin0 + (or (first refresh) never-evt) + (end-atomic))])))) + frames + (semaphore-peek-evt done-sema) + #f + done-sema + 0 + (make-hash) + 0)] + [cb-box (box #f)]) + (parameterize ([current-cb-box cb-box]) + (scheme_add_managed (current-custodian) + e + shutdown-eventspace! + cb-box ; retain callback until it's called + 1)) + e))) + +(define main-eventspace (make-eventspace* (current-thread))) +(define current-eventspace (make-parameter main-eventspace)) + +(define make-new-eventspace + (let ([make-eventspace + (lambda () + (letrec ([pause (make-semaphore)] + [es + (make-eventspace* + (thread + (lambda () + (sync pause) + (parameterize ([current-eventspace es]) + (yield (make-semaphore))))))]) + (semaphore-post pause) + es))]) + make-eventspace)) + +(define (queue-event eventspace thunk [level 'med]) + ((eventspace-queue-proc eventspace) (cons level thunk))) + +(define (queue-refresh-event eventspace thunk) + ((eventspace-queue-proc eventspace) (cons 'refresh thunk))) + +(define (handle-event thunk) + (let/ec esc + (let ([done? #f]) + (dynamic-wind + void + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-continuation-prompt thunk))) + (set! done? #t)) + (lambda () + (unless done? (esc (void)))))))) + +(define yield + (case-lambda + [() + (let ([e (current-eventspace)]) + (if (eq? (current-thread) (eventspace-handler-thread e)) + (let ([v (sync/timeout 0 ((eventspace-queue-proc e)))]) + (if v + (begin (handle-event v) #t) + #f)) + #f))] + [(evt) + (unless (or (evt? evt) + (eq? evt 'wait)) + (raise-type-error 'yield "evt or 'wait" evt)) + (let* ([e (current-eventspace)] + [handler? (eq? (current-thread) (eventspace-handler-thread e))]) + (cond + [(and (eq? evt 'wait) + (not handler?)) + #t] + [else + (define (wait-now) + (if handler? + (sync (if (eq? evt 'wait) + (wrap-evt e (lambda (_) #t)) + evt) + (handle-evt ((eventspace-queue-proc e)) + (lambda (v) + (when v (handle-event v)) + (yield evt)))) + (sync evt))) + (if (evt? evt) + ;; `yield' is supposed to return immediately if the + ;; event is already ready: + (sync/timeout wait-now evt) + (wait-now))]))])) + +(define yield-refresh + (lambda () + (let ([e (current-eventspace)]) + (and (eq? (current-thread) (eventspace-handler-thread e)) + (let loop ([result #f]) + (let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f))]) + (if v + (begin + (handle-event v) + (loop #t)) + result))))))) + +(define event-dispatch-handler (make-parameter void)) +(define (main-eventspace? e) + (eq? e main-eventspace)) + +(define (queue-callback thunk [high? #t]) + (let ([es (current-eventspace)]) + (when (eventspace-shutdown? es) + (error 'queue-callback "eventspace is shutdown: ~e" es)) + (queue-event es thunk (cond + [(not high?) 'lo] + [(eq? high? middle-queue-key) 'med] + [else 'hi])))) + +(define middle-queue-key (gensym 'middle)) + + +(define (add-timer-callback cb es) + ;; in atomic mode + (queue-event es cb 'timer-add)) +(define (remove-timer-callback cb es) + ;; in atomic mode + (unless (eventspace-shutdown? es) + (queue-event es cb 'timer-remove))) + +(define (register-frame-shown f on?) + (queue-event (current-eventspace) f (if on? + 'frame-add + 'frame-remove))) + +(define (get-top-level-windows [e (current-eventspace)]) + ;; called in event-pump thread + (hash-map (eventspace-frames-hash e) + (lambda (k v) k))) + +(define (other-modal? win) + ;; called in atomic mode in eventspace's thread + (let ([es (send win get-eventspace)]) + (or (positive? (eventspace-external-modal es)) + (let loop ([frames (get-top-level-windows es)]) + (and (pair? frames) + (let ([status (send (car frames) frame-relative-dialog-status win)]) + (case status + [(#f) (loop (cdr frames))] + [(same) #f] + [(other) #t]))))))) + +(define (eventspace-adjust-external-modal! es amt) + (atomically + (set-eventspace-external-modal! + es + (+ (eventspace-external-modal es) amt)))) + +(define (queue-quit-event) + ;; called in event-pump thread + (queue-event main-eventspace (application-quit-handler) 'med)) + +(define (queue-prefs-event) + ;; called in event-pump thread + (queue-event main-eventspace (application-pref-handler) 'med)) + +(define (queue-file-event file) + ;; called in event-pump thread + (queue-event main-eventspace (lambda () + ((application-file-handler) file)) + 'med)) + +(define (begin-busy-cursor) + (let ([e (current-eventspace)]) + (atomically + (set-eventspace-wait-cursor-count! + e + (add1 (eventspace-wait-cursor-count e))) + (when (= (eventspace-wait-cursor-count e) 1) + (for ([e (in-list (get-top-level-windows))]) + (send e set-wait-cursor-mode #t)))))) + +(define (end-busy-cursor) + (let ([e (current-eventspace)]) + (atomically + (set-eventspace-wait-cursor-count! + e + (sub1 (eventspace-wait-cursor-count e))) + (when (zero? (eventspace-wait-cursor-count e)) + (for ([e (in-list (get-top-level-windows))]) + (send e set-wait-cursor-mode #f)))))) + +(define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace)))) + +;; ---------------------------------------- + +;; Before exiting, wait until frames are closed, etc.: +(executable-yield-handler + (let ([old-eyh (executable-yield-handler)]) + (lambda (v) + (yield main-eventspace) + (old-eyh v)))) diff --git a/collects/mred/private/wx/common/rbtree.rkt b/collects/mred/private/wx/common/rbtree.rkt new file mode 100644 index 00000000..884cc91b --- /dev/null +++ b/collects/mred/private/wx/common/rbtree.rkt @@ -0,0 +1,316 @@ +#lang racket/base + +;;; red-black-tree.rkt -- Jens Axel S�gaard and Carl Eastlund -- 3rd nov 2003 + +;;; PURPOSE + +; This is an implementation of red/black trees, based on the galore.plt code + +;;; HISTORY + +; This is direct port of Jean-Christophe Filliatre's implementation +; of red-black trees in Ocaml. + +;; 13th jan 2010 [mflatt] +; - simplified for incorporation into MrEd; +; something like this should be in `scheme', instead. +;; 22nd jan 2004 [soegaard] +; - added set? +; - fixed bug in inter-list reported by Pinku Surana +;; 15th feb 2005 [soegaard] +; - numerous modifications to handle the case were +; elm= is finer than elm> and elm< +; - fixed serious bug in unbalanced-left +; (one sub tree was discarded, the other cloned) +; 17th feb 2005 [soegaard] +; - fixed bug in diff-list introduced (hopefully) the 15th +; 2nd nov 2005 [soegaard] +; - changed from unit to module/compare approach +; - renamed from red-black-tree-set.scm to raw-red-black-tree-set.scm +; 5th apr 2006 [cce] +; - copied from module to class approach +; - renamed to red-black-tree (from raw-red-black-tree-set) +; - inlined the provide declaration +; - fixed errors in the commented contracts for empty and get +; 2nd may 2006 [sstrickl] +; - fixed error in insert/combiner (replacing a black node turned it red) +; 5th may 2006 [cce] +; - udpated license statement regarding permission to use LGPL v2.1 + +;;; LICENSE + +; Rbset: Sets implemented as red-black trees. +; Copyright (C) 2000 Jean-Christophe FILLIATRE +; +; This software is free software; you can redistribute it and/or +; modify it under the terms of the GNU Library General Public +; License version 2, as published by the Free Software Foundation. +; +; 5th May 2006: Jean-Christophe Filliatre has given express written +; permission to redistribute and/or modify this software under the terms +; of any newer version of the GNU LGPL. +; +; This software is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +; +; See the GNU Library General Public License version 2 for more details +; (enclosed in the file LGPL). +; + +;; SETS IMPLEMENTED AS REB-BLACK TREES. + +(require racket/match + (for-syntax racket/base)) +(define-match-expander $ + (lambda (stx) + (syntax-case stx () + [(_ id pat ...) #'(struct id (pat ...))]))) + +(define-syntax-rule (if3 v less same more) + (let ([x v]) + (cond + [(x . < . 0) less] + [(x . = . 0) same] + [else more]))) + +(provide rbtree-get ; compare element set -> element/f + rbtree-insert ; compare element set -> set + rbtree-remove ; compare element set -> set + rbtree-min ; set -> element + ) + + +;; DATA DEFINITION + +;; A RED/BLACK TREE is either +;; 1. empty +;; or 2. (make-B l x r) +;; or 3. (make-R l x r) +;; where l and r are red/black trees and x is an element. + +(define empty '()) ; considered black +(define empty? null?) + +(define-struct B (l x r) #:transparent) ; Black tree +(define-struct R (l x r) #:transparent) ; Red tree +;; Constructor shorthands +(define (B- l x r) (make-B l x r)) +(define (R- l x r) (make-R l x r)) + +;; type predicate +(define (red-black-tree? s) + (or (null? s) (B? s) (R? s))) + + +;; for debugging +(define (->sexp t) + (define -> ->sexp) + (match t + ['() '()] + [($ B l x r) `(B ,(-> l) ,x ,(-> r))] + [($ R l x r) `(R ,(-> l) ,x ,(-> r))])) + + +;; INVARIANTS + +;; (* Invariants: (1) a red node has no red son, and (2) any path from the +;; root to a leaf has the same number of black nodes *) +;; +;; (* Note the use of two constructors [Black] and [Red] to save space +;; (resulting in longer code at a few places, e.g. in function [remove]). +;; These red-black trees saves 20\% of space w.r.t Ocaml's AVL, which +;; store the height into a fourth argument. *) + +;; type elt = Ord.t +;; type t = Empty | Black of t * elt * t | Red of t * elt * t + +;; (*s For debug only: checks whether a tree is properly colored *) + +;; check : rbt -> integer +;; checks invariants and return black height, +;; if the invariants are fulfilled +#; +(define (check s) + (match s + ['() 0] + [($ R ($ R _ _ _) _ _) (error "Red node with red parent" s)] + [($ R _ _ ($ R _ _ _)) (error "Red node with red parent" s)] + [($ B l _ r) (let ([height-left (check l)] + [height-right (check r)]) + (if (not (= height-left height-right)) + (error) + (+ height-left 1)))] + [($ R l _ r) (let ([height-left (check l)] + [height-right (check r)]) + (if (not (= height-left height-right)) + (error) + height-left))])) + +;; SET OPERATIONS + +(define (rbtree-get cmp x s) + (match s + ['() #f] + [($ B l v r) (if3 (cmp x v) + (rbtree-get cmp x l) + v + (rbtree-get cmp x r))] + [($ R l v r) (if3 (cmp x v) + (rbtree-get cmp x l) + v + (rbtree-get cmp x r))])) + +(define (rbtree-min s) + (match s + [($ B '() v _) v] + [($ R '() v _) v] + [($ B l _ _) (rbtree-min l)] + [($ R l _ _) (rbtree-min l)] + ['() (error 'rbtree-min "an empty set does not have an mimimum element")])) + +;; BALANCING + +(define (lbalance x1 x2 x3) + (let ([z x2] [d x3]) + (match x1 + [($ R ($ R a x b) y c) (R- (B- a x b) y (B- c z d))] + [($ R a x ($ R b y c)) (R- (B- a x b) y (B- c z d))] + [_ (B- x1 x2 x3)]))) + +(define (rbalance x1 x2 x3) + (let ([a x1] [x x2]) + (match x3 + [($ R ($ R b y c) z d) (R- (B- a x b) y (B- c z d))] + [($ R b y ($ R c z d)) (R- (B- a x b) y (B- c z d))] + [_ (B- x1 x2 x3)]))) + +;; INSERTION + +(define (rbtree-insert cmp x s) + (define (ins s) + (match s + ['() (R- empty x empty)] + [($ R a y b) (if3 (cmp x y) + (R- (ins a) y b) + s + (R- a y (ins b)))] + [($ B a y b) (if3 (cmp x y) + (lbalance (ins a) y b) + s + (rbalance a y (ins b)))])) + (let ([s1 (ins s)]) + ; color the root black + (match s1 + [($ B _ _ _) s1] + [($ R a y b) (B- a y b)] + ['() (error)]))) + +;; REMOVAL + +;; (* [unbalanced_left] repares invariant (2) when the black height of the +;; left son exceeds (by 1) the black height of the right son *) +;; [original spelling kept -- a quote is a quote ] + +(define (unbalanced-left s) + (match s + [($ R ($ B t1 x1 t2) x2 t3) (values (lbalance (R- t1 x1 t2) x2 t3) #f)] + [($ B ($ B t1 x1 t2) x2 t3) (values (lbalance (R- t1 x1 t2) x2 t3) #t)] + [($ B ($ R t1 x1 ($ B t2 x2 t3)) x3 t4) (values (B- t1 x1 (lbalance (R- t2 x2 t3) x3 t4)) #f)] + [_ (error 'unbalanced-left + (format "Black height of both sons were the same: ~a" + (->sexp s)))])) + +;; (* [unbalanced_right] repares invariant (2) when the black height of the +;; right son exceeds (by 1) the black height of the left son *) + +(define (unbalanced-right s) + (match s + [($ R t1 x1 ($ B t2 x2 t3)) (values (rbalance t1 x1 (R- t2 x2 t3)) #f)] + [($ B t1 x1 ($ B t2 x2 t3)) (values (rbalance t1 x1 (R- t2 x2 t3)) #t)] + [($ B t1 x1 ($ R ($ B t2 x2 t3) x3 t4)) (values (B- (rbalance t1 x1 (R- t2 x2 t3)) x3 t4) #f)] + [_ (error 'unbalanced-right + (format "Black height of both sons were the same: ~a" + (->sexp s)))])) + + + +;; (* [remove_min s = (s',m,b)] extracts the minimum [m] of [s], [s'] being the +;; resulting set, and indicates with [b] whether the black height has +;; decreased *) + +(define (remove-min s) + (match s + ['() (error "remove-min: Called on empty set")] + ;; minimum is reached + [($ B '() x '()) (values empty x #t)] + [($ B '() x ($ R l y r)) (values (B- l y r) x #f)] + [($ B '() _ ($ B _ _ _)) (error)] + [($ R '() x r) (values r x #f)] + ;; minimum is recursively extracted from [l] + [($ B l x r) (let-values ([(l1 m d) (remove-min l)]) + (let ([t (B- l1 x r)]) + (if d + (let-values ([(t d1) (unbalanced-right t)]) + (values t m d1)) + (values t m #f))))] + [($ R l x r) (let-values ([(l1 m d) (remove-min l)]) + (let ([t (R- l1 x r)]) + (if d + (let-values ([(t d1) (unbalanced-right t)]) + (values t m d1)) + (values t m #f))))])) + + +(define (blackify s) + (match s + [($ R l x r) (values (B- l x r) #f)] + [_ (values s #t)])) + +;; (* [remove_aux x s = (s',b)] removes [x] from [s] and indicates with [b] +;; whether the black height has decreased *) + +(define (rbtree-remove cmp x s) + (define (remove-aux s) + (match s + ['() (values empty #f)] + [($ B l y r) (if3 (cmp x y) + (let-values ([(l1 d) (remove-aux l)]) + (let ([t (B- l1 y r)]) + (if d + (unbalanced-right t) + (values t #f)))) + + (match r + ['() (blackify l)] + [_ (let-values ([(r1 m d) (remove-min r)]) + (let ([t (B- l m r1)]) + (if d + (unbalanced-left t) + (values t #f))))]) + + (let-values ([(r1 d) (remove-aux r)]) + (let ([t (B- l y r1)]) + (if d + (unbalanced-left t) + (values t #f)))))] + [($ R l y r) (if3 (cmp x y) + (let-values ([(l1 d) (remove-aux l)]) + (let ([t (R- l1 y r)]) + (if d + (unbalanced-right t) + (values t #f)))) + (match r + ['() (values l #f)] + [_ (let-values ([(r1 m d) (remove-min r)]) + (let ([t (R- l m r1)]) + (if d + (unbalanced-left t) + (values t #f))))]) + (let-values ([(r1 d) (remove-aux r)]) + (let ([t (R- l y r1)]) + (if d + (unbalanced-left t) + (values t #f)))))])) + (let-values ([(s1 ignore) (remove-aux s)]) + s1)) diff --git a/collects/mred/private/wx/common/timer.rkt b/collects/mred/private/wx/common/timer.rkt new file mode 100644 index 00000000..289eb651 --- /dev/null +++ b/collects/mred/private/wx/common/timer.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt" + "../../lock.rkt" + "queue.rkt") + +(provide timer%) + +;; FIXME: need checks +(defclass timer% object% + (init [notify-callback void] + [(ival interval) #f] + [just-once? #f]) + (define notify-cb notify-callback) + (define current-interval ival) + (define current-once? (and just-once? #t)) + (define cb #f) + (define es (current-eventspace)) + + (when (eventspace-shutdown? es) + (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es)) + + (def/public (interval) current-interval) + (define/private (do-start msec once?) + (as-entry + (lambda () + (do-stop) + (when (eventspace-shutdown? es) + (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es)) + (set! current-interval msec) + (set! current-once? (and once? #t)) + (letrec ([new-cb + (make-timer-callback (+ msec (current-inexact-milliseconds)) + (lambda () + (when (eq? cb new-cb) + (notify) + (as-entry + (lambda () + (unless once? + (when (eq? cb new-cb) + (do-start msec #f))))))))]) + (set! cb new-cb) + (add-timer-callback new-cb es))))) + (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]]) + (do-start msec once?)) + (define/private (do-stop) + (as-entry + (lambda () + (when cb + (remove-timer-callback cb es) + (set! cb #f))))) + (def/public (stop) (do-stop)) + (def/public (notify) (notify-cb) (void)) + (super-new) + (when ival + (start ival just-once?))) diff --git a/collects/mred/private/wx/common/utils.rkt b/collects/mred/private/wx/common/utils.rkt new file mode 100644 index 00000000..2fcf5748 --- /dev/null +++ b/collects/mred/private/wx/common/utils.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/atomic + "once.rkt") + +(provide (protect-out define-mz + + remember-to-free-later + free-remembered-now)) + +(define-ffi-definer define-mz #f) + +;; ---------------------------------------- + +(define to-free null) + +;; Remember to free an object that might currently be in use during a +;; callback: +(define (remember-to-free-later o) + (start-atomic) + (set! to-free (cons o to-free)) + (end-atomic)) + +;; Called outside the event loop to actually free objects that might +;; otherwise be in use during a callback: +(define (free-remembered-now free) + (start-atomic) + (for ([o (in-list (begin0 + to-free + (set! to-free null)))]) + (free o)) + (end-atomic)) diff --git a/collects/mred/private/wx/gtk/README.txt b/collects/mred/private/wx/gtk/README.txt new file mode 100644 index 00000000..2f55c326 --- /dev/null +++ b/collects/mred/private/wx/gtk/README.txt @@ -0,0 +1,17 @@ + +Allocation rules: + + * Use `as-gtk-allocation' when creating a Gtk widget that is the main + container for a given window<%> object. When the resulting + reference becomes unreachable, the widget will be released with + gtk_widget_destroy() through a finalizer. + + * Use `atomically' to create and attach a sub-widget within the main + widget. Don't use gtk_widget_destroy(); the containing widget will + destroy the enclosing widget. + + * For temporary objects, use `atomically' to wrap both the allocation + and release. + +Every call to a function whose name contains "new" needs to be in one +of those cases. diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt new file mode 100644 index 00000000..4d5a6499 --- /dev/null +++ b/collects/mred/private/wx/gtk/button.rkt @@ -0,0 +1,106 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt" + "pixbuf.rkt" + "message.rkt" + "../common/event.rkt") + +(provide + (protect-out button% + button-core%)) + +;; ---------------------------------------- + +(define-gtk gtk_button_new_with_mnemonic (_fun _string -> _GtkWidget)) +(define-gtk gtk_button_new (_fun -> _GtkWidget)) +(define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void)) + +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-signal-handler connect-clicked "clicked" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx queue-clicked))))) + +(defclass button-core% item% + (init parent cb label x y w h style font + [gtk_new_with_mnemonic gtk_button_new_with_mnemonic] + [gtk_new gtk_button_new]) + (init-field [event-type 'button]) + (inherit get-gtk get-client-gtk set-auto-size is-window-enabled? + get-window-gtk) + + (super-new [parent parent] + [gtk (cond + [(or (string? label) (not label)) + (as-gtk-allocation + (gtk_new_with_mnemonic (or (mnemonic-string label) "")))] + [(send label ok?) + (let ([pixbuf (bitmap->pixbuf label)]) + (atomically + (let ([gtk (as-gtk-allocation (gtk_new))] + [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk) + gtk)))] + [else + (as-gtk-allocation (gtk_new_with_mnemonic ""))])] + [callback cb] + [font font] + [no-show? (memq 'deleted style)]) + (define gtk (get-gtk)) + + (when (eq? event-type 'button) + (set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk) + GTK_CAN_DEFAULT))) + + (set-auto-size) + + (connect-clicked gtk) + + (when (memq 'border style) (set-border #t)) + + (define callback cb) + (define/public (clicked) + (when (is-window-enabled?) + (callback this (new control-event% + [event-type event-type] + [time-stamp (current-milliseconds)])))) + (define/public (queue-clicked) + ;; Called from event-handling thread + (queue-window-event this (lambda () (clicked)))) + + (define/override (get-label-gtk) + (gtk_bin_get_child (get-client-gtk))) + + (define/override (set-label s) + (cond + [(string? s) + (gtk_button_set_label gtk (mnemonic-string s))] + [else + (let ([pixbuf (bitmap->pixbuf s)]) + (atomically + (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_remove gtk (gtk_bin_get_child gtk)) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk))))])) + + (define/public (set-border on?) + (gtk_window_set_default (get-window-gtk) (if on? gtk #f)))) + +(defclass button% button-core% + (super-new)) + diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt new file mode 100644 index 00000000..eb19b784 --- /dev/null +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -0,0 +1,630 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw + ffi/unsafe/alloc + racket/draw/private/color + racket/draw/private/local + "../common/backing-dc.rkt" + "../common/canvas-mixin.rkt" + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "client-window.rkt" + "widget.rkt" + "dc.rkt" + "gl-context.rkt" + "combo.rkt" + "pixbuf.rkt" + "gcwin.rkt") + +(provide + (protect-out canvas%)) + +;; ---------------------------------------- + +(define-gobj g_object_freeze_notify (_fun _GtkWidget -> _void)) +(define-gobj g_object_thaw_notify (_fun _GtkWidget -> _void)) + +(define-gobj g_object_set_double (_fun _GtkWidget _string _double* (_pointer = #f) -> _void) + #:c-id g_object_set) +(define-gobj g_object_get_double (_fun _GtkWidget _string (r : (_ptr o _double)) (_pointer = #f) + -> _void -> r) + #:c-id g_object_get) + +(define-gtk gtk_drawing_area_new (_fun -> _GtkWidget)) + +(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) + +(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) + +(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) + +(define-gtk gtk_widget_set_double_buffered (_fun _GtkWidget _gboolean -> _void)) + +(define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject +(define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment)) +(define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void) + #:fail (lambda () + ;; This by-hand version doesn't produce quite the same notifications. + (lambda (gtk value lower upper step-inc page-inc page-size) + (atomically + (g_object_freeze_notify gtk) + (g_object_set_double gtk "lower" lower) + (g_object_set_double gtk "upper" upper) + (g_object_set_double gtk "step-increment" step-inc) + (g_object_set_double gtk "page-increment" page-inc) + (g_object_set_double gtk "page-size" page-size) + (let ([value (max lower (min value (- upper page-size)))]) + (gtk_adjustment_set_value gtk value)) + (g_object_thaw_notify gtk))))) +(define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*)) +(define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*) + #:fail (lambda () + (lambda (gtk) + (g_object_get_double gtk "upper")))) +(define-gtk gtk_adjustment_set_upper (_fun _GtkAdjustment _double* -> _void) + #:fail (lambda () + (lambda (gtk upper) + (g_object_set_double gtk "upper" upper)))) +(define-gtk gtk_adjustment_get_page_size (_fun _GtkAdjustment -> _double*) + #:fail (lambda () + (lambda (gtk) + (g_object_get_double gtk "page-size")))) +(define-gtk gtk_adjustment_set_page_size (_fun _GtkAdjustment _double* -> _void) + #:fail (lambda () + (lambda (gtk page-size) + (g_object_set_double gtk "page-size" page-size)))) +(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*) + #:fail (lambda () + (lambda (gtk) + (g_object_get_double gtk "page-increment")))) +(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void) + #:fail (lambda () + (lambda (gtk page-inc) + (g_object_set_double gtk "page-increment" page-inc)))) + +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void)) + +(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) + #:c-id g_object_set) + +(define-gdk gdk_gc_unref (_fun _pointer -> _void) + #:wrap (deallocator)) +(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer) + #:wrap (allocator gdk_gc_unref)) +(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)) +(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)) + +;; We rely some on the implementation of GtkComboBoxEntry to replace +;; the drawing routine. +(define-cstruct _GList ([data _pointer])) +(define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null)) +(define-gdk gdk_window_hide (_fun _pointer -> _void)) +(define (get-subwindow gtk) + (let* ([win (widget-window gtk)] + [subs (gdk_window_get_children win)]) + (if subs + (GList-data subs) + win))) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx combo-maybe-clicked))))) + +(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) + +(define-signal-handler connect-expose "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (when wx + (unless (send wx paint-or-queue-paint) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (widget-window gtk) gc #t + 0 0 32000 32000) + (gdk_gc_unref gc)))))) + #t)) + +(define-signal-handler connect-expose-border "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let* ([win (widget-window gtk)] + [gc (gdk_gc_new win)] + [gray #x8000]) + (when gc + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) + (let ([r (GdkEventExpose-area event)]) + (gdk_draw_rectangle win gc #t + (GdkRectangle-x r) + (GdkRectangle-y r) + (GdkRectangle-width r) + (GdkRectangle-height r))) + (gdk_gc_unref gc))))) + +(define-signal-handler connect-value-changed-h "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (do-value-changed gtk 'horizontal))) + +(define-signal-handler connect-value-changed-v "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (do-value-changed gtk 'vertical))) + +(define (do-value-changed gtk dir) + (let ([wx (gtk->wx gtk)]) + (when wx + (when (send wx deliver-scroll-callbacks?) + (queue-window-event wx (lambda () + (send wx do-scroll dir) + (flush-display)))))) + #t) + +(define canvas% + (canvas-mixin + (class (canvas-autoscroll-mixin (client-size-mixin window%)) + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) + + (inherit get-gtk set-size get-size get-client-size + on-size get-top-win + set-auto-size + adjust-client-delta infer-client-delta + is-auto-scroll? get-virtual-width get-virtual-height + refresh-for-autoscroll + get-eventspace) + + (define is-combo? (memq 'combo style)) + (define has-border? (or (memq 'border style) + (memq 'control-border style))) + + (define margin (if has-border? 1 0)) + + (define-values (client-gtk gtk + hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box + combo-button-gtk + scroll-width) + (atomically ;; need to connect all children to gtk to avoid leaks + (cond + [(or (memq 'hscroll style) + (memq 'vscroll style)) + (let* ([client-gtk (gtk_drawing_area_new)] + [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + ;; |------------------------------------| + ;; | h |-----------------| |-----------|| + ;; | | v | | v2 || + ;; | | | | [vscroll] || + ;; | | [h2 [hscroll]] | | [resize] || + ;; | |-----------------| |-----------|| + ;; |------------------------------------| + (when has-border? + (gtk_container_set_border_width h margin)) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (when (memq 'hscroll style) + (gtk_widget_show hscroll)) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (when (memq 'vscroll style) + (gtk_widget_show v2)) + (gtk_widget_show h2) + (when (memq 'hscroll style) + (gtk_widget_show resize-box)) + (gtk_widget_show client-gtk) + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request vscroll req) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f + (GtkRequisition-width req)))))] + [is-combo? + (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] + [orig-entry (gtk_bin_get_child gtk)]) + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] + [has-border? + (let ([client-gtk (gtk_drawing_area_new)] + [h (as-gtk-allocation (gtk_hbox_new #f 0))]) + (gtk_box_pack_start h client-gtk #t #t 0) + (gtk_container_set_border_width h margin) + (connect-expose-border h) + (gtk_widget_show client-gtk) + (values client-gtk h #f #f #f #f #f #f 0))] + [else + (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) + (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) + + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [no-show? (memq 'deleted style)] + [extra-gtks (if (eq? client-gtk gtk) + null + (if hscroll-adj + (list client-gtk hscroll-adj vscroll-adj) + (if combo-button-gtk + (list client-gtk combo-button-gtk) + (list client-gtk))))]) + + (set-size x y w h) + + (define dc (new dc% [canvas this])) + + (define for-gl? (memq 'gl style)) + (when for-gl? + (prepare-widget-gl-context client-gtk gl-config)) + + (gtk_widget_realize gtk) + (gtk_widget_realize client-gtk) + + (when resize-box + (let ([r (make-GtkRequisition 0 0)]) + (gtk_widget_size_request hscroll-gtk r) + (gtk_widget_set_size_request resize-box + (GtkRequisition-height r) + (GtkRequisition-height r)))) + + (connect-expose client-gtk) + #;(gtk_widget_set_double_buffered client-gtk #f) + (connect-key-and-mouse client-gtk) + (connect-focus client-gtk) + (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK + GDK_KEY_RELEASE_MASK + GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) + (unless (memq 'no-focus style) + (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) + GTK_CAN_FOCUS))) + (when combo-button-gtk + (connect-combo-key-and-mouse combo-button-gtk)) + + (when hscroll-adj (connect-value-changed-h hscroll-adj)) + (when vscroll-adj (connect-value-changed-v vscroll-adj)) + + (set-auto-size) + (adjust-client-delta (+ (* 2 margin) + (if (memq 'vscroll style) + scroll-width + 0)) + (+ (* 2 margin) + (if (memq 'hscroll style) + scroll-width + 0))) + + ;; Direct update is ok for a canvas, and it + ;; allows pushing updates to the screen even + ;; if the eventspace thread is busy indefinitely + (define/override (direct-update?) #t) + + (define/public (get-dc) dc) + + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h)) + + (define/override (get-client-gtk) client-gtk) + (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) + + (define/override (internal-pre-on-event gtk e) + (when (and (ptr-equal? gtk combo-button-gtk) + (send e button-down?)) + (on-popup)) + #f) + + (define/override (get-client-delta) + (values margin margin)) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay client-gtk)) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (paint-or-queue-paint) + ;; in atomic mode + (if for-gl? + (queue-paint) + (or (do-canvas-backing-flush #f) + (begin + (queue-paint) + #f)))) + + ;; overridden to extend for scheduled periodic flushes: + (define/public (schedule-periodic-backing-flush) + (void)) + (define/public (do-canvas-backing-flush ctx) + (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (widget-window client-gtk)))) + + (define/public (on-paint) (void)) + + (define/public (get-flush-window) client-gtk) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + ;; The `flush' method should be improved to flush local + ;; to the enclosing frame, instead of flushing globally. + (define/public (flush) + (flush-display)) + + (define/override (refresh) + (queue-paint)) + + (define/public (queue-backing-flush) + ;; called atomically + (unless for-gl? + (gtk_widget_queue_draw client-gtk))) + + (define/override (reset-child-dcs) + (when (dc . is-a? . dc%) + (reset-dc))) + + (send dc start-backing-retained) + + (define/private (reset-dc) + (send dc reset-backing-retained) + (refresh) + (send dc set-auto-scroll + (if (get-virtual-width) + (gtk_adjustment_get_value hscroll-adj) + 0) + (if (get-virtual-height) + (gtk_adjustment_get_value vscroll-adj) + 0))) + + (define/override (internal-on-client-size w h) + (reset-dc)) + (define/override (on-client-size w h) + (let ([xb (box 0)] + [yb (box 0)]) + (get-size xb yb) + (on-size (unbox xb) (unbox yb)))) + + (define/public (show-scrollbars h? v?) + (when hscroll-gtk + (if h? + (gtk_widget_show hscroll-gtk) + (gtk_widget_hide hscroll-gtk))) + (when vscroll-gtk + (if v? + (gtk_widget_show vscroll-gtk) + (gtk_widget_hide vscroll-gtk))) + (when (and hscroll-gtk vscroll-gtk) + (cond + [(and v? h?) + (gtk_widget_show resize-box)] + [(and v? (not h?)) + ;; remove corner + (gtk_widget_hide resize-box)])) + (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) + (+ (* 2 margin) (if h? scroll-width 0)))) + + (define suspend-scroll-callbacks? #f) + (define/public (deliver-scroll-callbacks?) (not suspend-scroll-callbacks?)) + (define/private (as-scroll-change thunk) + (atomically + (set! suspend-scroll-callbacks? #t) + (begin0 + (thunk) + (set! suspend-scroll-callbacks? #f)))) + + + (define/private (configure-adj adj scroll-gtk len page pos) + (when (and scroll-gtk adj) + (as-scroll-change + (lambda () + (if (zero? len) + (gtk_adjustment_configure adj 0 0 1 1 1 1) + (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))))) + + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)) + + (define/override (reset-dc-for-autoscroll) + (reset-dc)) + + (define/private (dispatch which proc [default (void)]) + (if (eq? which 'vertical) + (if vscroll-adj (proc vscroll-adj) default) + (if hscroll-adj (proc hscroll-adj) default))) + + (define/public (set-scroll-page which v) + (dispatch which (lambda (adj) + (let ([old (gtk_adjustment_get_page_size adj)]) + (unless (= old v) + (as-scroll-change + (lambda () + (gtk_adjustment_set_page_size adj v) + (gtk_adjustment_set_page_increment adj v) + (gtk_adjustment_set_upper adj (+ (- v old) + (gtk_adjustment_get_upper adj)))))))))) + (define/public (set-scroll-range which v) + (dispatch which (lambda (adj) + (as-scroll-change + (lambda () + (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))))) + (define/public (set-scroll-pos which v) + (dispatch which (lambda (adj) + (as-scroll-change + (lambda () + (gtk_adjustment_set_value adj v)))))) + + (define/public (get-scroll-page which) + (if (is-auto-scroll?) + 0 + (->long (dispatch which gtk_adjustment_get_page_size 0)))) + (define/public (get-scroll-range which) + (if (is-auto-scroll?) + 0 + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0)))) + (define/public (get-scroll-pos which) + (if (is-auto-scroll?) + 0 + (->long (dispatch which gtk_adjustment_get_value 0)))) + + (define clear-bg? + (and (not (memq 'transparent style)) + (not (memq 'no-autoclear style)))) + (define transparent? + (memq 'transparent style)) + (define gc #f) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col)) + (define/public (get-canvas-background-for-clearing) + ;; called in event-dispatch mode + (if clear-bg? + (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))] + [w (widget-window gtk)] + [gc (gdk_gc_new w)]) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 + (conv (color-red bg-col)) + (conv (color-green bg-col)) + (conv (color-blue bg-col)))) + gc) + #f)) + + (when is-combo? + (connect-changed client-gtk)) + + (define combo-count 0) + (define/public (clear-combo-items) + (atomically + (for ([n (in-range combo-count)]) + (gtk_combo_box_remove_text gtk 0)) + (set! combo-count 0))) + (define/public (append-combo-item str) + (atomically + (set! combo-count (add1 combo-count)) + (gtk_combo_box_append_text gtk str))) + + (when is-combo? (append-combo-item "...")) + + (define/public (on-popup) (void)) + + (define/public (combo-maybe-clicked) + (let ([i (gtk_combo_box_get_active gtk)]) + (when (i . > . -1) + (gtk_combo_box_set_active gtk -1) + (queue-window-event this (lambda () (on-combo-select i)))))) + (define/public (on-combo-select i) (void)) + + (define/public (set-combo-text t) (void)) + + (define/public (do-scroll direction) + (if (is-auto-scroll?) + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction direction] + [position (get-scroll-pos direction)])))) + (define/public (on-scroll e) (void)) + + (define/public (scroll x y) + (when (is-auto-scroll?) + (as-scroll-change + (lambda () + (when (and hscroll-adj (>= x 0)) + (gtk_adjustment_set_value + hscroll-adj + (floor + (* x (- (gtk_adjustment_get_upper hscroll-adj) + (gtk_adjustment_get_page_size hscroll-adj)))))) + (when (and vscroll-adj (>= y 0)) + (gtk_adjustment_set_value + vscroll-adj + (floor + (* y (- (gtk_adjustment_get_upper vscroll-adj) + (gtk_adjustment_get_page_size vscroll-adj)))))))) + (refresh-for-autoscroll))) + + (define/public (warp-pointer x y) (void)) + + (define/override (get-virtual-h-pos) + (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj)))) + (define/override (get-virtual-v-pos) + (inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj)))) + + (define/public (set-resize-corner on?) (void)) + + (define reg-blits null) + + (define/private (register-one-blit x y w h on-pixbuf off-pixbuf) + (let* ([cwin (widget-window client-gtk)]) + (atomically + (let ([win (create-gc-window cwin x y w h)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc win on-pixbuf w h) + (make-gc-hide-desc win off-pixbuf w h))]) + (cons win r)))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (fix-bitmap-size on w h on-x on-y)] + [off (fix-bitmap-size off w h off-x off-y)]) + (let ([on-pixbuf (bitmap->pixbuf on)] + [off-pixbuf (bitmap->pixbuf off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (g_object_unref (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null)))))) diff --git a/collects/mred/private/wx/gtk/check-box.rkt b/collects/mred/private/wx/gtk/check-box.rkt new file mode 100644 index 00000000..f9efa580 --- /dev/null +++ b/collects/mred/private/wx/gtk/check-box.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "button.rkt" + "utils.rkt" + "types.rkt" + "../../lock.rkt") + +(provide + (protect-out check-box%)) + +;; ---------------------------------------- + +(define-gtk gtk_check_button_new_with_mnemonic (_fun _string -> _GtkWidget)) +(define-gtk gtk_check_button_new (_fun -> _GtkWidget)) +(define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) + +(defclass check-box% button-core% + (super-new [gtk_new_with_mnemonic gtk_check_button_new_with_mnemonic] + [gtk_new gtk_check_button_new] + [event-type 'check-box]) + (inherit get-gtk) + + (define/public (set-value v) + (atomically + (set! no-clicked? #t) + (gtk_toggle_button_set_active (get-gtk) v) + (set! no-clicked? #f))) + + (define no-clicked? #f) + (define/override (queue-clicked) + (unless no-clicked? (super queue-clicked))) + + (define/public (get-value) + (gtk_toggle_button_get_active (get-gtk)))) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt new file mode 100644 index 00000000..39802d2c --- /dev/null +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -0,0 +1,100 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "types.rkt" + "utils.rkt" + "window.rkt" + "combo.rkt" + "../common/event.rkt" + "../common/queue.rkt") + +(provide + (protect-out choice%)) + +;; ---------------------------------------- + +(define-gtk gtk_combo_box_new_text (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx queue-clicked))))) + +(defclass choice% item% + (init parent cb label + x y w h + choices style font) + (inherit get-gtk set-auto-size) + + (define gtk (as-gtk-allocation (gtk_combo_box_new_text))) + (define count (length choices)) + + (for ([l (in-list choices)]) + (gtk_combo_box_append_text gtk l)) + + ;; Hack to access the combobox's private child, where is + ;; where the keyboard focus goes. + (define button-gtk (extract-combo-button gtk)) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks (list button-gtk)] + [callback cb] + [no-show? (memq 'deleted style)]) + + (gtk_combo_box_set_active gtk 0) + + (install-control-font (gtk_bin_get_child gtk) font) + + (set-auto-size) + + (connect-changed gtk) + (connect-focus button-gtk) + (connect-combo-key-and-mouse button-gtk) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))) + (define ignore-clicked? #f) + (define/public (queue-clicked) + ;; called in event-handling thread + (unless ignore-clicked? + (queue-window-event this (lambda () (clicked))))) + + (define/public (set-selection i) + (atomically + (set! ignore-clicked? #t) + (gtk_combo_box_set_active gtk i) + (set! ignore-clicked? #f))) + (define/public (get-selection) + (gtk_combo_box_get_active gtk)) + (define/public (number) count) + (define/public (clear) + (atomically + (set! ignore-clicked? #t) + (for ([i (in-range count)]) + (gtk_combo_box_remove_text gtk 0)) + (set! count 0) + (set! ignore-clicked? #f))) + (public [-append append]) + (define (-append l) + (atomically + (set! ignore-clicked? #t) + (set! count (add1 count)) + (gtk_combo_box_append_text gtk l) + (when (= count 1) + (set-selection 0)) + (set! ignore-clicked? #f)))) + diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt new file mode 100644 index 00000000..4382815f --- /dev/null +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -0,0 +1,53 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "widget.rkt" + "window.rkt" + "utils.rkt" + "const.rkt" + "types.rkt") + +(provide + (protect-out client-size-mixin)) + +;; ---------------------------------------- + +(define-signal-handler connect-size-allocate "size-allocate" + (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) + (lambda (gtk a) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx save-client-size + (GtkAllocation-x a) + (GtkAllocation-y a) + (GtkAllocation-width a) + (GtkAllocation-height a)))) + #t)) + +(define (client-size-mixin %) + (class % + (init client-gtk) + + (connect-size-allocate client-gtk) + + (define client-x 0) + (define client-y 0) + + (define/public (on-client-size w h) (void)) + + (define/public (save-client-size x y w h) + ;; Called in the Gtk event-loop thread + (set! client-x x) + (set! client-y y) + (queue-window-event this (lambda () + (internal-on-client-size w h) + (on-client-size w h)))) + + (define/public (internal-on-client-size w h) + (void)) + + (define/override (get-client-delta) + (values client-x client-y)) + + (super-new))) \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt new file mode 100644 index 00000000..64f9edbd --- /dev/null +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -0,0 +1,271 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc + racket/draw/unsafe/bstr + "../../syntax.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "../common/local.rkt" + "../common/freeze.rkt" + "utils.rkt" + "types.rkt" + "pixbuf.rkt") + +(provide + (protect-out clipboard-driver% + has-x-selection? + _GtkSelectionData + gtk_selection_data_get_length + gtk_selection_data_get_data + primary-atom + get-selection-eventspace)) + +(define (has-x-selection?) #t) + +(define _GtkClipboard (_cpointer 'GtkClipboard)) +(define _GtkDisplay _pointer) +(define _GtkSelectionData (_cpointer 'GtkSelectionData)) + +;; Recent versions of Gtk provide function calls to +;; access data, but use structure when the functions are +;; not available +(define-cstruct _GtkSelectionDataT ([selection _GdkAtom] + [target _GdkAtom] + [type _GdkAtom] + [format _int] + [data _pointer] + [length _int] + [display _GtkDisplay])) + + +(define-gdk gdk_atom_intern (_fun _string _gboolean -> _GdkAtom)) + +(define-gtk gtk_clipboard_get (_fun _GdkAtom -> _GtkClipboard)) +(define-gtk gtk_clipboard_set_with_data (_fun _GtkClipboard _pointer _uint + _fpointer _fpointer + _pointer + -> _void)) +(define-gtk gtk_selection_data_set (_fun _GtkSelectionData + _GdkAtom + _int + _bytes + _int + -> _void)) +(define-gtk gtk_selection_data_free (_fun _GtkSelectionData -> _void)) +(define-gtk gtk_selection_data_get_length (_fun _GtkSelectionData -> _int) + #:fail (lambda () GtkSelectionDataT-length)) +(define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer) + #:fail (lambda () GtkSelectionDataT-data)) + +(define-cstruct _GtkTargetEntry ([target _pointer] + [flags _uint] + [info _uint])) + +(define (get-data cb sel-data info self-box) + (send (ptr-ref self-box _scheme) provide-data info sel-data)) +(define get_data + (function-ptr get-data (_fun #:atomic? #t _GtkClipboard _GtkSelectionData _int _pointer -> _void))) + +(define (clear-owner cb self-box) + (send (ptr-ref self-box _scheme) replaced self-box)) +(define clear_owner + (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) + +(define primary-atom (gdk_atom_intern "PRIMARY" #t)) +(define clipboard-atom (gdk_atom_intern "CLIPBOARD" #t)) + +(define the-x-selection-driver #f) + +;; ---------------------------------------- + +(define _request-fun (_fun #:atomic? #t _GtkClipboard (_or-null _GtkSelectionData) _pointer -> _void)) +(define _request-string-fun (_fun #:atomic? #t _GtkClipboard _string _pointer -> _void)) +(define _request-image-fun (_fun #:atomic? #t _GtkClipboard _GdkPixbuf _pointer -> _void)) + +(define (handle-receipt backref data convert) + (let ([l (ptr-ref backref _racket)]) + (free-immobile-cell backref) + (set-box! (car l) (and data (convert data))) + (semaphore-post (cdr l)))) + +(define (make-request-backref) + (let ([l (cons (box #f) (make-semaphore))]) + (values l (malloc-immobile-cell l)))) + +(define (wait-request-backref l) + (semaphore-wait (cdr l)) + (unbox (car l))) + +(define (request-received cb data backref) + (handle-receipt backref + data + (lambda (v) + (let ([bstr (scheme_make_sized_byte_string + (gtk_selection_data_get_data v) + (gtk_selection_data_get_length v) + 1)]) + bstr)))) + +(define (string-request-received cb str backref) + (handle-receipt backref + str + (lambda (str) str))) + +(define (image-request-received cb pix backref) + (handle-receipt backref + pix + pixbuf->bitmap)) + +(define request_received (function-ptr request-received _request-fun)) +(define string_request_received (function-ptr string-request-received _request-string-fun)) +(define image_request_received (function-ptr image-request-received _request-image-fun)) + +(define-gtk gtk_clipboard_request_contents + (_fun _GtkClipboard _GdkAtom (_fpointer = request_received) _pointer -> _void)) +(define-gtk gtk_clipboard_request_text + (_fun _GtkClipboard (_fpointer = string_request_received) _pointer -> _void)) +(define-gtk gtk_clipboard_request_image + (_fun _GtkClipboard (_fpointer = image_request_received) _pointer -> _void)) + +;; ---------------------------------------- + +(defclass clipboard-driver% object% + (init-field [x-selection? #f]) + + (when x-selection? + (set! the-x-selection-driver this)) + + (define client #f) + (define client-data #f) + (define client-types #f) + (define client-orig-types #f) + + (define cb (gtk_clipboard_get + (if x-selection? + primary-atom + clipboard-atom))) + (define self-box #f) + + (define/public (get-client) client) + + (define/public (set-client c orig-types) + (let ([all-data (if x-selection? + ;; In X selection mode, get the data on demand: + #f + ;; In clipboard mode, we can get the data + ;; now, so it's ready if anyone asks: + (for/list ([t (in-list orig-types)]) + (send c get-data t)))] + [types (for/list ([t (in-list orig-types)]) + (if (equal? t "TEXT") + "UTF8_STRING" + t))]) + (let-values ([(orig-types types all-data) + ;; For "TEXT", provide "UTF8_STRING", "STRING", and "TEXT": + (if (member "TEXT" orig-types) + (values (append orig-types (list "TEXT" "TEXT")) + (append types (list "STRING" "TEXT")) + (and all-data (append all-data + (let loop ([all-data all-data] + [orig-types orig-types]) + (if (equal? "TEXT" (car orig-types)) + (list (car all-data) (car all-data)) + (loop (cdr all-data) (cdr orig-types))))))) + (values orig-types types all-data))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) + + (free target-strings))))) + + (define/public (replaced s-box) + ;; In atomic mode + (when (ptr-equal? s-box self-box) + (set! self-box #f) + (let ([c client]) + (when c + (set! client #f) + (set! client-data #f) + (set! client-types #f) + (set! client-orig-types #f) + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced)))))) + (free-immobile-cell s-box)) + + (define/public (provide-data i sel-data) + ;; In atomic mode; if it's the selection (not clipboard), + ;; then hopefully we're in the right eventspace + (let ([bstr (if client + (if client-data + (list-ref client-data i) + (constrained-reply (send client get-client-eventspace) + (lambda () + (send client get-data + (list-ref client-orig-types i))) + #"")) + #"")]) + (gtk_selection_data_set sel-data + (gdk_atom_intern (list-ref client-types i) #t) + 8 + bstr + (bytes-length bstr)))) + + (define/public (get-data data-format) + (let* ([data-format (if (equal? data-format "TEXT") + "UTF8_STRING" + data-format)] + [atom (gdk_atom_intern data-format #t)]) + (wait-request-backref + (atomically + (let-values ([(l backref) (make-request-backref)]) + (gtk_clipboard_request_contents cb atom backref) + l))))) + + (define/public (get-text-data) + (wait-request-backref + (atomically + (let-values ([(l backref) (make-request-backref)]) + (gtk_clipboard_request_text cb backref) + l)))) + + (define/public (get-bitmap-data) + (wait-request-backref + (atomically + (let-values ([(l backref) (make-request-backref)]) + (gtk_clipboard_request_image cb backref) + l)))) + + (super-new)) + +(define (get-selection-eventspace) + (and the-x-selection-driver + (let ([c (send the-x-selection-driver get-client)]) + (and c + (send c get-client-eventspace))))) diff --git a/collects/mred/private/wx/gtk/colordialog.rkt b/collects/mred/private/wx/gtk/colordialog.rkt new file mode 100644 index 00000000..c850fe4b --- /dev/null +++ b/collects/mred/private/wx/gtk/colordialog.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw/private/color + "types.rkt" + "utils.rkt" + "stddialog.rkt") + +(provide + (protect-out get-color-from-user + color-dialog-works?)) + +(define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget)) + +(define-gtk gtk_color_selection_dialog_get_color_selection (_fun _GtkWidget -> _GtkWidget) + #:fail (lambda () #f)) +(define-gtk gtk_color_selection_get_current_color (_fun _GtkWidget (c : (_ptr o _GdkColor)) -> _void -> c)) +(define-gtk gtk_color_selection_set_current_color (_fun _GtkWidget _GdkColor-pointer -> _void)) + +(define (color-dialog-works?) + (and gtk_color_selection_dialog_get_color_selection #t)) + +(define (get-color-from-user message parent color) + (let ([d (as-gtk-window-allocation + (gtk_color_selection_dialog_new (or message "Choose Color")))] + [to-gdk (lambda (c) (arithmetic-shift c 8))]) + (when color + (gtk_color_selection_set_current_color + (gtk_color_selection_dialog_get_color_selection d) + (make-GdkColor + 0 + (to-gdk (color-red color)) + (to-gdk (color-green color)) + (to-gdk (color-blue color))))) + (and (eq? (show-dialog d) 'ok) + (let ([c (gtk_color_selection_get_current_color + (gtk_color_selection_dialog_get_color_selection d))]) + (make-object color% + (arithmetic-shift (GdkColor-red c) -8) + (arithmetic-shift (GdkColor-green c) -8) + (arithmetic-shift (GdkColor-blue c) -8)))))) + + \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/combo.rkt b/collects/mred/private/wx/gtk/combo.rkt new file mode 100644 index 00000000..212aadfe --- /dev/null +++ b/collects/mred/private/wx/gtk/combo.rkt @@ -0,0 +1,118 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt") + +;; Hacks for working with GtkComboBox[Entry] + +(provide + (protect-out extract-combo-button + connect-combo-key-and-mouse)) + +;; ---------------------------------------- + +(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) +(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) + +(define-gobj g_signal_parse_name (_fun _string + _GType + (id : (_ptr o _uint)) + (_ptr o _GQuark) + _gboolean + -> (r : _gboolean) + -> (and r id))) + +(define-gobj g_type_from_name (_fun _string -> _GType)) + +(define _GSignalMatchType _int) +(define _GQuark _uint32) +(define _GClosure _int) +(define-gobj g_signal_handler_find (_fun _GtkWidget + _GSignalMatchType + _uint ; signal_id + _GQuark ; detail + _GClosure ; closure + _pointer ; func + _pointer ; data + -> _ulong)) +(define-gobj g_signal_handler_disconnect (_fun _GtkWidget _uint -> _void)) +(define-gobj g_signal_handler_block (_fun _GtkWidget _uint -> _void)) +(define-gobj g_signal_handler_unblock (_fun _GtkWidget _uint -> _void)) + +(define-gobj g_signal_emit (_fun _GtkWidget + _uint + _GQuark + _pointer + (r : (_ptr o _gboolean)) + -> _void + -> r)) + +(define G_SIGNAL_MATCH_ID 1) + +(define button-press-id #f) + +(define unblocked? #f) +(define-signal-handler connect-reorder-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer _long -> _gboolean) + (lambda (gtk event other-id) + (if unblocked? + #f + (let ([v (do-button-event gtk event #f #f)]) + (or v + (begin + (g_signal_handler_unblock gtk other-id) + (let ([r (g_signal_emit gtk + button-press-id + 0 + event)]) + (g_signal_handler_block gtk other-id) + r))))))) + +;; Dependence on the implemenation of GtkComboBox: +;; Keyboard focus and other actions are based on a private button widget +;; inside a GtkComboBox, so we extract it. +(define (extract-combo-button gtk) + (let ([all null] + [ext null]) + (gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f) + (gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f) + (for-each (lambda (e) + (set! all (filter (lambda (a) (not (ptr-equal? a e))) + all))) + ext) + (unless (= 1 (length all)) + (error "expected Gtk combobox to have one private child")) + (car all))) + +;; More dependence on the implemenation of GtkComboBox: +;; The memnu-popup action is implemented by seeting a button-press-event +;; signal handler on `button-gtk'. Since Gtk calls signal handlers in the +;; order that they're registered, our button-press-event handler doesn't +;; get called first, so it can't cancel the button press due to modality +;; or an `on-subwindow-event' result. We effectively reorder the callbacks +;; by finding the old one, blocking it, and then unblocking during a +;; redispatch. +(define (connect-combo-key-and-mouse button-gtk) + (unless button-press-id + (set! button-press-id + (g_signal_parse_name "button-press-event" (g_type_from_name "GtkWidget") #f))) + (let ([hand-id + (and button-press-id + (let ([hand-id (g_signal_handler_find button-gtk + G_SIGNAL_MATCH_ID + button-press-id + 0 + 0 + #f + #f)]) + (if (zero? hand-id) + #f + (begin + (g_signal_handler_block button-gtk hand-id) + hand-id))))]) + (connect-key-and-mouse button-gtk (and hand-id #t)) + (when hand-id + (connect-reorder-button-press button-gtk (cast hand-id _long _pointer))))) diff --git a/collects/mred/private/wx/gtk/const.rkt b/collects/mred/private/wx/gtk/const.rkt new file mode 100644 index 00000000..f7650353 --- /dev/null +++ b/collects/mred/private/wx/gtk/const.rkt @@ -0,0 +1,138 @@ +#lang racket/base + +(provide (except-out (all-defined-out) <<)) + +(define GTK_WINDOW_TOPLEVEL 0) + +(define << arithmetic-shift) + +(define GDK_EXPOSURE_MASK (1 . << . 1)) +(define GDK_POINTER_MOTION_MASK (1 . << . 2)) +(define GDK_POINTER_MOTION_HINT_MASK (1 . << . 3)) +(define GDK_BUTTON_MOTION_MASK (1 . << . 4)) +(define GDK_BUTTON1_MOTION_MASK (1 . << . 5)) +(define GDK_BUTTON2_MOTION_MASK (1 . << . 6)) +(define GDK_BUTTON3_MOTION_MASK (1 . << . 7)) +(define GDK_BUTTON_PRESS_MASK (1 . << . 8)) +(define GDK_BUTTON_RELEASE_MASK (1 . << . 9)) +(define GDK_KEY_PRESS_MASK (1 . << . 10)) +(define GDK_KEY_RELEASE_MASK (1 . << . 11)) +(define GDK_ENTER_NOTIFY_MASK (1 . << . 12)) +(define GDK_LEAVE_NOTIFY_MASK (1 . << . 13)) +(define GDK_FOCUS_CHANGE_MASK (1 . << . 14)) +(define GDK_STRUCTURE_MASK (1 . << . 15)) +(define GDK_PROPERTY_CHANGE_MASK (1 . << . 16)) +(define GDK_VISIBILITY_NOTIFY_MASK (1 . << . 17)) +(define GDK_PROXIMITY_IN_MASK (1 . << . 18)) +(define GDK_PROXIMITY_OUT_MASK (1 . << . 19)) +(define GDK_SUBSTRUCTURE_MASK (1 . << . 20)) +(define GDK_SCROLL_MASK (1 . << . 21)) +(define GDK_ALL_EVENTS_MASK #x3FFFFE) + + +(define GTK_TOPLEVEL (1 . << . 4)) +(define GTK_NO_WINDOW (1 . << . 5)) +(define GTK_REALIZED (1 . << . 6)) +(define GTK_MAPPED (1 . << . 7)) +(define GTK_VISIBLE (1 . << . 8)) +(define GTK_SENSITIVE (1 . << . 9)) +(define GTK_PARENT_SENSITIVE (1 . << . 10)) +(define GTK_CAN_FOCUS (1 . << . 11)) +(define GTK_HAS_FOCUS (1 . << . 12)) +(define GTK_CAN_DEFAULT (1 . << . 13)) +(define GTK_HAS_DEFAULT (1 . << . 14)) +(define GTK_HAS_GRAB (1 . << . 15)) +(define GTK_RC_STYLE (1 . << . 16)) +(define GTK_COMPOSITE_CHILD (1 . << . 17)) +(define GTK_NO_REPARENT (1 . << . 18)) +(define GTK_APP_PAINTABLE (1 . << . 19)) +(define GTK_RECEIVES_DEFAULT (1 . << . 20)) +(define GTK_DOUBLE_BUFFERED (1 . << . 21)) +(define GTK_NO_SHOW_ALL (1 . << . 22)) + +(define GDK_SHIFT_MASK (1 . << . 0)) +(define GDK_LOCK_MASK (1 . << . 1)) +(define GDK_CONTROL_MASK (1 . << . 2)) +(define GDK_MOD1_MASK (1 . << . 3)) +(define GDK_MOD2_MASK (1 . << . 4)) +(define GDK_MOD3_MASK (1 . << . 5)) +(define GDK_MOD4_MASK (1 . << . 6)) +(define GDK_MOD5_MASK (1 . << . 7)) +(define GDK_BUTTON1_MASK (1 . << . 8)) +(define GDK_BUTTON2_MASK (1 . << . 9)) +(define GDK_BUTTON3_MASK (1 . << . 10)) +(define GDK_BUTTON4_MASK (1 . << . 11)) +(define GDK_BUTTON5_MASK (1 . << . 12)) +(define GDK_SUPER_MASK (1 . << . 26)) +(define GDK_HYPER_MASK (1 . << . 27)) +(define GDK_META_MASK (1 . << . 28)) +(define GDK_RELEASE_MASK (1 . << . 30)) + +(define GDK_NOTHING -1) +(define GDK_DELETE 0) +(define GDK_DESTROY 1) +(define GDK_EXPOSE 2) +(define GDK_MOTION_NOTIFY 3) +(define GDK_BUTTON_PRESS 4) +(define GDK_2BUTTON_PRESS 5) +(define GDK_3BUTTON_PRESS 6) +(define GDK_BUTTON_RELEASE 7) +(define GDK_KEY_PRESS 8) +(define GDK_KEY_RELEASE 9) +(define GDK_ENTER_NOTIFY 10) +(define GDK_LEAVE_NOTIFY 11) +(define GDK_FOCUS_CHANGE 12) +(define GDK_CONFIGURE 13) +(define GDK_MAP 14) +(define GDK_UNMAP 15) +(define GDK_PROPERTY_NOTIFY 16) +(define GDK_SELECTION_CLEAR 17) +(define GDK_SELECTION_REQUEST 18) +(define GDK_SELECTION_NOTIFY 19) +(define GDK_PROXIMITY_IN 20) +(define GDK_PROXIMITY_OUT 21) +(define GDK_DRAG_ENTER 22) +(define GDK_DRAG_LEAVE 23) +(define GDK_DRAG_MOTION 24) +(define GDK_DRAG_STATUS 25) +(define GDK_DROP_START 26) +(define GDK_DROP_FINISHED 27) +(define GDK_CLIENT_EVENT 28) +(define GDK_VISIBILITY_NOTIFY 29) +(define GDK_NO_EXPOSE 30) +(define GDK_SCROLL 31) +(define GDK_WINDOW_STATE 32) +(define GDK_SETTING 33) +(define GDK_OWNER_CHANGE 34) +(define GDK_GRAB_BROKEN 35) +(define GDK_DAMAGE 36) + +(define G_TYPE_STRING (16 . << . 2)) + +(define GTK_POLICY_ALWAYS 0) +(define GTK_POLICY_AUTOMATIC 1) +(define GTK_POLICY_NEVER 2) + +(define GDK_WINDOW_STATE_WITHDRAWN (1 . << . 0)) +(define GDK_WINDOW_STATE_ICONIFIED (1 . << . 1)) +(define GDK_WINDOW_STATE_MAXIMIZED (1 . << . 2)) +(define GDK_WINDOW_STATE_STICKY (1 . << . 3)) +(define GDK_WINDOW_STATE_FULLSCREEN (1 . << . 4)) +(define GDK_WINDOW_STATE_ABOVE (1 . << . 5)) +(define GDK_WINDOW_STATE_BELOW (1 . << . 6)) + +(define GDK_HINT_POS (1 . << . 0)) +(define GDK_HINT_MIN_SIZE (1 . << . 1)) +(define GDK_HINT_MAX_SIZE (1 . << . 2)) +(define GDK_HINT_BASE_SIZE (1 . << . 3)) +(define GDK_HINT_ASPECT (1 . << . 4)) +(define GDK_HINT_RESIZE_INC (1 . << . 5)) +(define GDK_HINT_WIN_GRAVITY (1 . << . 6)) +(define GDK_HINT_USER_POS (1 . << . 7)) +(define GDK_HINT_USER_SIZE (1 . << . 8)) + +(define GDK_SCROLL_UP 0) +(define GDK_SCROLL_DOWN 1) +(define GDK_SCROLL_LEFT 2) +(define GDK_SCROLL_RIGHT 3) + diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt new file mode 100644 index 00000000..da92895a --- /dev/null +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -0,0 +1,95 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw + "utils.rkt" + "types.rkt" + "pixbuf.rkt" + "../common/cursor-draw.rkt" + "../../syntax.rkt") + +(provide + (protect-out cursor-driver% + get-arrow-cursor-handle + get-watch-cursor-handle)) + +(define GDK_ARROW 2) ; ugly! +(define GDK_CROSSHAIR 34) +(define GDK_HAND2 60) +(define GDK_SB_H_DOUBLE_ARROW 108) +(define GDK_SB_V_DOUBLE_ARROW 116) +(define GDK_XTERM 152) +(define GDK_TARGET 128) +(define GDK_WATCH 150) + +(define gdk-cursors + (make-hasheq (list + (cons 'arrow GDK_ARROW) + (cons 'cross GDK_CROSSHAIR) + (cons 'ibeam GDK_XTERM) + (cons 'bullseye GDK_TARGET) + (cons 'watch 150) + (cons 'size-e/w GDK_SB_H_DOUBLE_ARROW) + (cons 'size-n/s GDK_SB_V_DOUBLE_ARROW) + (cons 'size-ne/sw draw-ne/sw) + (cons 'size-nw/se draw-nw/se) + (cons 'blank void) + (cons 'hand GDK_HAND2)))) + +(define _GdkCursor (_cpointer 'GdkCursor)) +(define-gdk gdk_cursor_new (_fun _int -> _GdkCursor)) +(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) +(define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor)) + +(define (get-arrow-cursor-handle) + (hash-ref gdk-cursors 'arrow #f)) + +(define (get-watch-cursor-handle) + (let ([v (hash-ref gdk-cursors 'watch #f)]) + (if (number? v) + (begin + (send (new cursor-driver%) set-standard 'watch) + (get-watch-cursor-handle)) + v))) + +(defclass cursor-driver% object% + + (define handle #f) + + (define/public (ok?) (and handle #t)) + + (define/public (set-standard sym) + (let ([v (hash-ref gdk-cursors sym #f)]) + (cond + [(not v) (void)] + [(number? v) + (let ([c (gdk_cursor_new v)]) + (hash-set! gdk-cursors sym c) + (set! handle c))] + [(procedure? v) + (let ([bm (make-cursor-image v)]) + (let ([c (gdk_cursor_new_from_pixbuf + (gdk_display_get_default) + (bitmap->pixbuf bm) + 8 + 8)]) + (hash-set! gdk-cursors sym c) + (set! handle c)))] + [else (set! handle v)]))) + + (define/public (set-image image mask hot-spot-x hot-spot-y) + (let ([bm (make-object bitmap% 16 16 #f #t)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask) + (send dc set-bitmap #f)) + (let ([pixbuf (bitmap->pixbuf bm)]) + (set! handle + (gdk_cursor_new_from_pixbuf + (gdk_display_get_default) + pixbuf + hot-spot-x + hot-spot-y))))) + + (define/public (get-handle) handle) + + (super-new)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt new file mode 100644 index 00000000..ed66511f --- /dev/null +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -0,0 +1,157 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "window.rkt" + "x11.rkt" + "win32.rkt" + "gl-context.rkt" + "../../lock.rkt" + "../common/backing-dc.rkt" + racket/draw/unsafe/cairo + racket/draw/private/dc + racket/draw/private/bitmap + racket/draw/private/local + ffi/unsafe/alloc) + +(provide + (protect-out dc% + do-backing-flush + x11-bitmap%)) + +(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) + #:wrap (allocator cairo_destroy)) + +(define x11-bitmap% + (class bitmap% + (init w h gdk-win) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define pixmap (gdk_pixmap_new gdk-win w h (if gdk-win -1 24))) + (define s + (cairo_xlib_surface_create (gdk_x11_display_get_xdisplay + (gdk_drawable_get_display pixmap)) + (gdk_x11_drawable_get_xid pixmap) + (gdk_x11_visual_get_xvisual + (gdk_drawable_get_visual pixmap)) + w + h)) + + ;; initialize bitmap to white: + (let ([cr (cairo_create s)]) + (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) + (cairo_paint cr) + (cairo_destroy cr)) + + ;; `get-gdk-pixmap' and `install-gl-context' are + ;; localized in "gl-context.rkt" + (define/public (get-gdk-pixmap) pixmap) + (define/public (install-gl-context new-gl) (set! gl new-gl)) + + (define gl #f) + (define/override (get-bitmap-gl-context) gl) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (gobject-unref pixmap) + (set! s #f))))) + +(define win32-bitmap% + (class bitmap% + (init w h gdk-win) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define s + (if (not gdk-win) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hdc)))))) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (set! s #f))))) + +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (inherit end-delay) + (define canvas cnvs) + + (super-new) + + (define gl #f) + (define/override (get-gl-context) + (or gl + (let ([v (create-widget-gl-context (send canvas get-client-gtk))]) + (when v (set! gl v)) + v))) + + (define/override (make-backing-bitmap w h) + (cond + [(and (eq? 'unix (system-type)) + (send canvas get-canvas-background)) + (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))] + [(and (eq? 'windows (system-type)) + (send canvas get-canvas-background)) + (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] + [else + (super make-backing-bitmap w h)])) + + (define/override (get-backing-size xb yb) + (send canvas get-client-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) + (send canvas queue-backing-flush)) + + (define/override (flush) + (send canvas flush)) + + (define/override (request-delay) + (request-flush-delay (send canvas get-flush-window))) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) + +(define (do-backing-flush canvas dc win) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cr (gdk_cairo_create win)]) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt new file mode 100644 index 00000000..209930d9 --- /dev/null +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../common/queue.rkt" + "../common/dialog.rkt" + "../../lock.rkt" + "types.rkt" + "utils.rkt" + "frame.rkt") + +(provide + (protect-out dialog%)) + +(define GTK_WIN_POS_CENTER 1) +(define GTK_WIN_POS_CENTER_ON_PARENT 4) + +(define GDK_WINDOW_TYPE_HINT_DIALOG 1) + +(define-gtk gtk_window_set_position (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void)) + +(define dialog% + (class (dialog-mixin frame%) + (inherit get-gtk + get-parent) + + (super-new [is-dialog? #t]) + + (gtk_window_set_type_hint (get-gtk) GDK_WINDOW_TYPE_HINT_DIALOG) + + (let ([p (get-parent)]) + (when p + (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) + + (define/override (center dir wrt) + (if (eq? dir 'both) + (gtk_window_set_position (get-gtk) + (if (get-parent) + GTK_WIN_POS_CENTER_ON_PARENT + GTK_WIN_POS_CENTER)) + (super center dir wrt))))) diff --git a/collects/mred/private/wx/gtk/filedialog.rkt b/collects/mred/private/wx/gtk/filedialog.rkt new file mode 100644 index 00000000..9520771f --- /dev/null +++ b/collects/mred/private/wx/gtk/filedialog.rkt @@ -0,0 +1,100 @@ +#lang racket/base +(require ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + racket/class + racket/match + "types.rkt" + "utils.rkt" + "widget.rkt" + "queue.rkt" + "stddialog.rkt" + "../common/handlers.rkt" + "../common/queue.rkt") + +(provide + (protect-out file-selector)) + +(define _GtkFileChooserDialog _GtkWidget) +(define _GtkFileChooser (_cpointer 'GtkFileChooser)) +(define _GtkFileChooserAction + (_enum (list 'open 'save 'select-folder 'create-folder))) + +;; FIXME: really there are varargs here, but we don't need them for +;; our purposes +(define-gtk gtk_file_chooser_dialog_new + (_fun _string (_or-null _GtkWindow) + _GtkFileChooserAction + _string _GtkResponse + _string _GtkResponse + (_or-null _pointer) + -> _GtkFileChooserDialog)) +;; FIXME - should really be _GtkDialog but no subtyping +(define-gtk gtk_dialog_run (_fun _GtkFileChooserDialog -> _int)) +;; FIXME ;; these should really be _GtkFileChooser but no subtyping +(define-gtk gtk_file_chooser_get_filename + (_fun _GtkFileChooserDialog -> _gpath/free)) +(define-gtk gtk_file_chooser_get_filenames + (_fun _GtkFileChooserDialog -> (_GSList _gpath/free))) +(define-gtk gtk_file_chooser_set_current_name + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_current_folder + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_do_overwrite_confirmation + (_fun _GtkFileChooserDialog _gboolean -> _void)) +(define-gtk gtk_file_chooser_set_select_multiple + (_fun _GtkFileChooserDialog _gboolean -> _void)) + +(define _GtkFileFilter (_cpointer 'GtkFileFilter)) +(define-gtk gtk_file_filter_new (_fun -> _GtkFileFilter)) +(define-gtk gtk_file_filter_set_name + (_fun _GtkFileFilter _string -> _void)) +(define-gtk gtk_file_filter_add_pattern + (_fun _GtkFileFilter _string -> _void)) + +(define-gtk gtk_file_chooser_add_filter + (_fun _GtkFileChooserDialog _GtkFileFilter -> _void)) + +(define (file-selector message directory filename + extension ;; always ignored + filters style parent) + (define type (car style)) ;; the rest of `style' is irrelevant on Gtk + (define dlg (as-gtk-window-allocation + (gtk_file_chooser_dialog_new + message (and parent (send parent get-gtk)) + (case type + [(dir) 'select-folder] + [(put) 'save] + [else 'open]) + "gtk-cancel" 'cancel + ;; no stock names for "Select" + (case type + [(dir) "Choose"] + [(put) "gtk-save"] + [(get) "gtk-open"] + [(multi) "Choose"]) + 'accept + #f))) + (when (eq? 'multi type) + (gtk_file_chooser_set_select_multiple dlg #t)) + (when filename + (gtk_file_chooser_set_current_name dlg filename)) + (when directory + (gtk_file_chooser_set_current_folder dlg directory)) + (when (eq? 'put type) + (gtk_file_chooser_set_do_overwrite_confirmation dlg #t)) + (for ([f (in-list filters)]) + (match f + [(list name glob) + (let ([ff (gtk_file_filter_new)]) + (gtk_file_filter_set_name ff name) + (gtk_file_filter_add_pattern ff glob) + (gtk_file_chooser_add_filter dlg ff))])) + (define ans (and (eq? 'accept (show-dialog dlg)) + (if (eq? type 'multi) + (gtk_file_chooser_get_filenames dlg) + (gtk_file_chooser_get_filename dlg)))) + (gtk_widget_destroy dlg) + ans) + +(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt new file mode 100644 index 00000000..994ab5f2 --- /dev/null +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -0,0 +1,485 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/promise + racket/runtime-path + racket/draw + (for-syntax (only-in racket/base quote)) + "../../syntax.rkt" + "../../lock.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "window.rkt" + "client-window.rkt" + "widget.rkt" + "cursor.rkt" + "pixbuf.rkt" + "../common/queue.rkt") + +(provide + (protect-out frame% + display-origin + display-size + location->window)) + +;; ---------------------------------------- + +(define GDK_GRAVITY_NORTH_WEST 1) +(define GDK_GRAVITY_STATIC 10) + +(define _GList (_cpointer/null 'GList)) +(define-glib g_list_insert (_fun _GList _pointer _int -> _GList)) +(define-glib g_list_free (_fun _GList -> _void)) + +(define-gtk gtk_window_new (_fun _int -> _GtkWidget)) +(define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) +(define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int)) + -> _void + -> (values w h))) +(define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void)) +(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void)) +(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int)) + -> _void + -> (values x y))) +(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void)) +(define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void)) +(define-gtk gtk_window_fullscreen (_fun _GtkWindow -> _void)) + +(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) + +(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) + +(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) +(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) + +(define-cstruct _GdkGeometry ([min_width _int] + [min_height _int] + [max_width _int] + [max_height _int] + [base_width _int] + [base_height _int] + [width_inc _int] + [height_inc _int] + [min_aspect _double] + [max_aspect _double] + [win_gravity _int])) +(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void)) + + +(define-signal-handler connect-delete "delete-event" + (_fun _GtkWidget -> _gboolean) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (queue-window-event wx (lambda () + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f))))))))) + +(define-signal-handler connect-configure "configure-event" + (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean) + (lambda (gtk a) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx remember-size + (GdkEventConfigure-width a) + (GdkEventConfigure-height a)))) + #f)) + +(define-cstruct _GdkEventWindowState ([type _int] + [window _GtkWindow] + [send_event _int8] + [changed_mask _int] + [new_window_state _int])) + + +(define-signal-handler connect-window-state "window-state-event" + (_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean) + (lambda (gtk evt) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx on-window-state + (GdkEventWindowState-changed_mask evt) + (GdkEventWindowState-new_window_state evt)))) + #f)) + +(define-runtime-path plt-16x16-file '(lib "icons/plt-16x16.png")) +(define-runtime-path plt-32x32-file '(lib "icons/plt-32x32.png")) +(define-runtime-path plt-48x48-file '(lib "icons/plt-48x48.png")) + +(define icon-pixbufs+glist + (delay + (let ([icons (map + (lambda (fn) + (bitmap->pixbuf (make-object bitmap% fn 'png/alpha))) + (list plt-16x16-file + plt-32x32-file + plt-48x48-file))]) + (cons + ;; keep pixbuf pointers to avoid GC: + icons + ;; a glist: + (for/fold ([l #f]) ([i (in-list icons)]) + (g_list_insert l i -1)))))) + +;; used for location->window +(define all-frames (make-hasheq)) + +(define frame% + (class (client-size-mixin window%) + (init parent + label + x y w h + style) + (init [is-dialog? #f]) + + (inherit get-gtk set-size on-size + pre-on-char pre-on-event + get-client-delta get-size + get-parent get-eventspace + adjust-client-delta + queue-on-size) + + (define gtk (as-gtk-window-allocation + (gtk_window_new GTK_WINDOW_TOPLEVEL))) + (when (memq 'no-caption style) + (gtk_window_set_decorated gtk #f)) + (define-values (vbox-gtk panel-gtk) + (atomically + (let ([vbox-gtk (gtk_vbox_new #f 0)] + [panel-gtk (gtk_fixed_new)]) + (gtk_container_add gtk vbox-gtk) + (gtk_box_pack_end vbox-gtk panel-gtk #t #t 0) + (values vbox-gtk panel-gtk)))) + (gtk_widget_show vbox-gtk) + (gtk_widget_show panel-gtk) + + (unless is-dialog? + (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) + + (define/override (get-client-gtk) panel-gtk) + (define/override (get-window-gtk) gtk) + + (super-new [parent parent] + [gtk gtk] + [client-gtk panel-gtk] + [no-show? #t] + [add-to-parent? #f] + [extra-gtks (list panel-gtk)]) + + (set-size x y w h) + + (when (memq 'hide-menu-bar style) + (gtk_window_fullscreen gtk)) + + (connect-delete gtk) + (connect-configure gtk) + (connect-focus gtk) + (connect-window-state gtk) + + (define saved-title (or label "")) + (define is-modified? #f) + + (when label + (gtk_window_set_title gtk label)) + + ;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move panel-gtk child-gtk x y) + (gtk_widget_set_size_request child-gtk w h)) + + (define/public (on-close) #t) + + (define/public (set-menu-bar mb) + (let ([mb-gtk (send mb get-gtk)]) + (gtk_box_pack_start vbox-gtk mb-gtk #t #t 0) + (gtk_widget_show mb-gtk)) + (let ([h (send mb set-top-window this)]) + ;; adjust client delta right away, so that we make + ;; better assumptions about the client size and more + ;; quickly converge to the right size of the frame + ;; based on its content + (adjust-client-delta 0 h)) + ;; Hack: calls back into the mred layer to re-compute + ;; sizes. By calling this early enough, the frame won't + ;; grow if it doesn't have to grow to accomodate the menu bar. + (send this resized)) + + (define saved-enforcements (vector 0 0 -1 -1)) + + (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) + (define (to-max v) (if (= v -1) #x3FFFFF v)) + (set! saved-enforcements (vector min-x min-y max-x max-y)) + (gtk_window_set_geometry_hints gtk gtk + (make-GdkGeometry min-x min-y + (to-max max-x) (to-max max-y) + 0 0 + inc-x inc-y + 0.0 0.0 + 0) + (bitwise-ior GDK_HINT_MIN_SIZE + GDK_HINT_MAX_SIZE + GDK_HINT_RESIZE_INC))) + + (define/override (get-top-win) this) + + (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1))) + (define/public (get-dc-lock) dc-lock) + + (define/override (get-dialog-level) 0) + (define/public (frame-relative-dialog-status win) #f) + + (define/override (get-unset-pos) -11111) + + (define/override (center dir wrt) + (let ([w-box (box 0)] + [h-box (box 0)] + [sx-box (box 0)] + [sy-box (box 0)] + [sw-box (box 0)] + [sh-box (box 0)]) + (get-size w-box h-box) + (let ([p (get-parent)]) + (if p + (begin + (send p get-size sw-box sh-box) + (set-box! sx-box (send p get-x)) + (set-box! sy-box (send p get-y))) + (display-size sw-box sh-box #t))) + (let* ([sw (unbox sw-box)] + [sh (unbox sh-box)] + [fw (unbox w-box)] + [fh (unbox h-box)]) + (set-top-position (if (or (eq? dir 'both) + (eq? dir 'horizontal)) + (+ (unbox sx-box) (quotient (- sw fw) 2)) + -11111) + (if (or (eq? dir 'both) + (eq? dir 'vertical)) + (+ (unbox sy-box) (quotient (- sh fh) 2)) + -11111))))) + + (define/public (set-top-position x y) + (unless (and (= x -11111) (= y -11111)) + (gtk_widget_set_uposition gtk + (if (= x -11111) -2 x) + (if (= y -11111) -2 y)))) + + (define/override (really-set-size gtk x y processed-x processed-y w h) + (set-top-position x y) + (gtk_window_resize gtk (max 1 w) (max 1 h)) + (queue-on-size)) + + (define/override (show on?) + (let ([es (get-eventspace)]) + (when (and on? + (eventspace-shutdown? es)) + (error (string->symbol + (format "show method in ~a" + (if (frame-relative-dialog-status this) + 'dialog% + 'frame%))) + "eventspace has been shutdown") + (when saved-child + (if (eq? (current-thread) (eventspace-handler-thread es)) + (send saved-child paint-children) + (let ([s (make-semaphore)]) + (queue-callback (lambda () + (when saved-child + (send saved-child paint-children)) + (semaphore-post s))) + (sync/timeout 1 s)))))) + (super show on?)) + + (define saved-child #f) + (define/override (register-child child on?) + (unless on? (error 'register-child-in-frame "did not expect #f")) + (unless (or (not saved-child) (eq? child saved-child)) + (error 'register-child-in-frame "expected only one child")) + (set! saved-child child)) + (define/override (register-child-in-parent on?) + (void)) + + (define/override (direct-show on?) + ;; atomic mode + (if on? + (hash-set! all-frames this #t) + (hash-remove! all-frames this)) + (super direct-show on?) + (when on? (gtk_window_deiconify gtk)) + (register-frame-shown this on?)) + + (define/public (destroy) + ;; atomic mode + (direct-show #f)) + + (define/override (on-client-size w h) + (void)) + + (define/augment (is-enabled-to-root?) #t) + + (define big-icon #f) + (define small-icon #f) + (define/public (set-icon bm mask [mode 'both]) + (let ([bm (if mask + (let* ([nbm (make-object bitmap% + (send bm get-width) + (send bm get-height) + #f + #t)] + [dc (make-object bitmap-dc% nbm)]) + (send dc draw-bitmap bm 0 0 + 'solid (make-object color% "black") + mask) + (send dc set-bitmap #f) + nbm) + bm)]) + (case mode + [(small) (set! small-icon bm)] + [(big) (set! big-icon bm)] + [(both) + (set! small-icon bm) + (set! big-icon bm)]) + (let ([small-pixbuf + (if small-icon + (bitmap->pixbuf small-icon) + (car (car (force icon-pixbufs+glist))))] + [big-pixbufs + (if big-icon + (list (bitmap->pixbuf big-icon)) + (cdr (car (force icon-pixbufs+glist))))]) + (atomically + (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf + big-pixbufs)]) + (g_list_insert l i -1))]) + (gtk_window_set_icon_list gtk l) + (g_list_free l)))))) + + (define child-has-focus? #f) + (define reported-activate #f) + (define queued-active? #f) + (define/public (on-focus-child on?) + ;; atomic mode + (set! child-has-focus? on?) + (unless queued-active? + (set! queued-active? #t) + (queue-window-event this + (lambda () + (let ([on? child-has-focus?]) + (set! queued-active? #f) + (unless (eq? on? reported-activate) + (set! reported-activate on?) + (on-activate on?))))))) + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (define/override (client-to-screen x y) + (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC) + (let-values ([(dx dy) (gtk_window_get_position gtk)] + [(cdx cdy) (get-client-delta)]) + (gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST) + (set-box! x (+ (unbox x) dx cdx)) + (set-box! y (+ (unbox y) dy cdy)))) + + (define/public (on-toolbar-click) (void)) + (define/public (on-menu-click) (void)) + + (define/public (on-menu-command c) (void)) + + (def/public-unimplemented on-mdi-activate) + + (define/public (on-activate on?) (void)) + + (define/public (designate-root-frame) (void)) + + (def/public-unimplemented system-menu) + + (define/public (set-modified mod?) + (unless (eq? is-modified? (and mod? #t)) + (set! is-modified? (and mod? #t)) + (set-title saved-title))) + + (define waiting-cursor? #f) + (define/public (set-wait-cursor-mode on?) + (set! waiting-cursor? on?) + (when in-window + (send in-window enter-window))) + + (define current-cursor-handle #f) + (define in-window #f) + (define/override (set-parent-window-cursor in-win c) + (set! in-window in-win) + (let ([c (if waiting-cursor? + (get-watch-cursor-handle) + c)]) + (unless (eq? c current-cursor-handle) + (atomically + (set! current-cursor-handle c) + (gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle)) + #f + c)))))) + (define/override (enter-window) (void)) + (define/override (leave-window) (void)) + + (define/override (check-window-cursor win) + (when in-window + (send in-window enter-window))) + + (define maximized? #f) + (define is-iconized? #f) + + (define/public (is-maximized?) + maximized?) + (define/public (maximize on?) + ((if on? gtk_window_maximize gtk_window_unmaximize) gtk)) + + (define/public (on-window-state changed value) + (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED)) + (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED)))) + (when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED)) + (set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED))))) + + (define/public (iconized?) + is-iconized?) + (define/public (iconize on?) + (if on? + (gtk_window_iconify gtk) + (gtk_window_deiconify gtk))) + + (def/public-unimplemented get-menu-bar) + + (define/public (set-title s) + (set! saved-title s) + (gtk_window_set_title gtk (if is-modified? + (string-append s "*") + s))))) + +;; ---------------------------------------- + +(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) +(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) + +(define (display-origin x y all?) (set-box! x 0) (set-box! y 0)) +(define (display-size w h all?) + (let ([s (gdk_screen_get_default)]) + (set-box! w (gdk_screen_get_width s)) + (set-box! h (gdk_screen_get_height s)))) + +(define (location->window x y) + (for/or ([f (in-hash-keys all-frames)]) + (let ([fx (send f get-x)] + [fw (send f get-width)]) + (and (<= fx x (+ fx fw)) + (let ([fy (send f get-y)] + [fh (send f get-height)]) + (<= fy y (+ fy fh))) + f)))) diff --git a/collects/mred/private/wx/gtk/gauge.rkt b/collects/mred/private/wx/gtk/gauge.rkt new file mode 100644 index 00000000..dda1a9a5 --- /dev/null +++ b/collects/mred/private/wx/gtk/gauge.rkt @@ -0,0 +1,61 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt") + +(provide + (protect-out gauge%)) + +;; ---------------------------------------- + +(define-gtk gtk_progress_bar_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_progress_bar_set_fraction (_fun _GtkWidget _double* -> _void)) +(define-gtk gtk_progress_bar_set_orientation (_fun _GtkWidget _int -> _void)) + +(define GTK_PROGRESS_BOTTOM_TO_TOP 2) + +(defclass gauge% item% + (init parent + label + rng + x y w h + style + font) + (inherit get-gtk set-auto-size) + + (super-new [parent parent] + [gtk (as-gtk-allocation (gtk_progress_bar_new #f))] + [no-show? (memq 'deleted style)]) + (define gtk (get-gtk)) + + (when (memq 'vertical style) + (gtk_progress_bar_set_orientation gtk GTK_PROGRESS_BOTTOM_TO_TOP)) + + (set-auto-size) + + (define range rng) + (define value 0) + + (define/private (reset) + (gtk_progress_bar_set_fraction gtk + (if (zero? range) + 0.0 + (/ value range)))) + + (define/public (get-range) + range) + (define/public (set-range r) + (set! range r) + (set! value (min value r)) + (reset)) + + (define/public (set-value v) + (set! value v) + (reset)) + (define/public (get-value) + value)) diff --git a/collects/mred/private/wx/gtk/gcwin.rkt b/collects/mred/private/wx/gtk/gcwin.rkt new file mode 100644 index 00000000..d017aeba --- /dev/null +++ b/collects/mred/private/wx/gtk/gcwin.rkt @@ -0,0 +1,95 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "window.rkt") + +(provide + (protect-out scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-window + make-gc-show-desc + make-gc-hide-desc)) + +(define-cstruct _GdkWindowAttr + ([title _string] + [event_mask _int] + [x _int] + [y _int] + [width _int] + [height _int] + [wclass _int] ; GDK_INPUT_OUTPUT + [visual _pointer] + [colormap _pointer] + [window_type _int] ; GDK_WINDOW_CHILD + [cursor _pointer] + [wmclass_name _string] + [wmclass_class _string] + [override_redirect _gboolean] + [type_hint _int])) + +(define << arithmetic-shift) + +(define GDK_WA_TITLE (1 . << . 1)) +(define GDK_WA_X (1 . << . 2)) +(define GDK_WA_Y (1 . << . 3)) +(define GDK_WA_CURSOR (1 . << . 4)) +(define GDK_WA_COLORMAP (1 . << . 5)) +(define GDK_WA_VISUAL (1 . << . 6)) +(define GDK_WA_WMCLASS (1 . << . 7)) +(define GDK_WA_NOREDIR (1 . << . 8)) +(define GDK_WA_TYPE_HINT (1 . << . 9)) + +(define GDK_INPUT_OUTPUT 0) + +(define GDK_WINDOW_CHILD 2) + +(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint + -> _GdkWindow)) + +(define-gdk gdk_window_show _fpointer) +(define-gdk gdk_window_hide _fpointer) +(define-gdk gdk_display_flush _fpointer) +(define-gdk gdk_draw_pixbuf _fpointer) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define (create-gc-window cwin x y w h) + (let ([win (gdk_window_new cwin (make-GdkWindowAttr + "" + 0 + x y w h + GDK_INPUT_OUTPUT + #f #f + GDK_WINDOW_CHILD + #f + "" "" #f 0) + (bitwise-ior GDK_WA_X + GDK_WA_Y))]) + win)) + +(define (make-draw win pixbuf w h) + (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void + gdk_draw_pixbuf + win #f pixbuf + 0 0 0 0 w h + 0 0 0)) + +(define (make-flush) + (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f)) + +(define (make-gc-show-desc win pixbuf w h) + (vector + (vector 'ptr_ptr_ptr->void gdk_window_show win #f #f) + (make-draw win pixbuf w h) + (make-flush))) + +(define (make-gc-hide-desc win pixbuf w h) + (vector + ;; draw the ``off'' bitmap so we can flush immediately + (make-draw win pixbuf w h) + (make-flush) + ;; hide the window; it may take a while for the underlying canvas + ;; to refresh: + (vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f))) diff --git a/collects/mred/private/wx/gtk/gl-context.rkt b/collects/mred/private/wx/gtk/gl-context.rkt new file mode 100644 index 00000000..40769f44 --- /dev/null +++ b/collects/mred/private/wx/gtk/gl-context.rkt @@ -0,0 +1,188 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + (prefix-in draw: racket/draw/private/gl-context) + racket/draw/private/gl-config + "types.rkt" + "utils.rkt") + +(provide + (protect-out prepare-widget-gl-context + create-widget-gl-context + + create-and-install-gl-context + get-gdk-pixmap + install-gl-context)) + +(define gdkglext-lib + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (ffi-lib "libgdkglext-x11-1.0" '("0")))) +(define gtkglext-lib + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (ffi-lib "libgtkglext-x11-1.0" '("0")))) + +(define-ffi-definer define-gdkglext gdkglext-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-gtkglext gtkglext-lib + #:default-make-fail make-not-available) + +(define _GdkGLContext (_cpointer/null 'GdkGLContext)) +(define _GdkGLDrawable (_cpointer 'GdkGLDrawable)) +(define _GdkGLConfig (_cpointer 'GdkGLConfig)) +(define _GdkGLPixmap _GdkGLDrawable) +(define _GdkPixmap _pointer) + +(define-gdkglext gdk_gl_init (_fun (_ptr i _int) + (_ptr i _pointer) + -> _void) + #:fail (lambda () void)) + +(define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig)) + #:fail (lambda () (lambda args #f))) +(define-gtkglext gdk_gl_config_new_for_screen (_fun _GdkScreen (_list i _int) -> (_or-null _GdkGLConfig))) + +(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) + +(define-gtkglext gtk_widget_set_gl_capability (_fun _GtkWidget + _GdkGLConfig + _GdkGLContext + _gboolean + _int + -> _gboolean) + #:fail (lambda () (lambda args #f))) + +(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext) + #:fail (lambda () (lambda args #f))) +(define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable)) + +(define-gdkglext gdk_gl_context_destroy (_fun _GdkGLContext -> _void) + #:wrap (deallocator)) + +(define-gdkglext gdk_gl_context_new (_fun _GdkGLDrawable _GdkGLContext _gboolean _int + -> _GdkGLContext) + #:wrap (allocator gdk_gl_context_destroy)) + +(define-gdkglext gdk_gl_drawable_gl_begin (_fun _GdkGLDrawable + _GdkGLContext + -> _gboolean)) +(define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void)) +(define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void)) + +(define-gdkglext gdk_pixmap_set_gl_capability (_fun _GdkPixmap _GdkGLConfig _pointer + -> _GdkGLPixmap)) + +(define GDK_GL_RGBA_TYPE 0) + +(define GDK_GL_USE_GL 1) +(define GDK_GL_BUFFER_SIZE 2) +(define GDK_GL_LEVEL 3) +(define GDK_GL_RGBA 4) +(define GDK_GL_DOUBLEBUFFER 5) +(define GDK_GL_STEREO 6) +(define GDK_GL_AUX_BUFFERS 7) +(define GDK_GL_RED_SIZE 8) +(define GDK_GL_GREEN_SIZE 9) +(define GDK_GL_BLUE_SIZE 10) +(define GDK_GL_ALPHA_SIZE 11) +(define GDK_GL_DEPTH_SIZE 12) +(define GDK_GL_STENCIL_SIZE 13) +(define GDK_GL_ACCUM_RED_SIZE 14) +(define GDK_GL_ACCUM_GREEN_SIZE 15) +(define GDK_GL_ACCUM_BLUE_SIZE 16) +(define GDK_GL_ACCUM_ALPHA_SIZE 17) +(define GDK_GL_SAMPLE_BUFFERS 100000) +(define GDK_GL_SAMPLES 100001) +(define GDK_GL_ATTRIB_LIST_NONE 0) + +;; ---------------------------------------- + +(define (config->GdkGLConfig d conf can-double?) + (gdk_gl_config_new (append + (list GDK_GL_RGBA) + (if can-double? + (if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null) + null) + (if (send conf get-stereo) (list GDK_GL_STEREO) null) + (list + GDK_GL_DEPTH_SIZE (send conf get-depth-size) + GDK_GL_STENCIL_SIZE (send conf get-stencil-size) + GDK_GL_ACCUM_RED_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_GREEN_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_BLUE_SIZE (send conf get-accum-size) + GDK_GL_ACCUM_ALPHA_SIZE (send conf get-accum-size)) + #; + (list GDK_GL_SAMPLES (send conf get-multisample-size)) + (list GDK_GL_ATTRIB_LIST_NONE)))) + +;; ---------------------------------------- + +(define gl-context% + (class draw:gl-context% + (init-field [gl gl] + [drawable drawable]) + + (define/override (draw:do-call-as-current t) + (dynamic-wind + (lambda () + (gdk_gl_drawable_gl_begin drawable gl)) + t + (lambda () + (gdk_gl_drawable_gl_end drawable)))) + + (define/override (draw:do-swap-buffers) + (gdk_gl_drawable_swap_buffers drawable)) + + (super-new))) + +;; ---------------------------------------- + +(define inited? #f) +(define (init!) + (unless inited? + (set! inited? #t) + (gdk_gl_init 0 #f))) + +(define (prepare-widget-gl-context gtk config) + (init!) + (let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk) + (or config + (new gl-config%)) + #t)]) + (when config + (gtk_widget_set_gl_capability gtk + config + #f + #t + 0)))) + +(define (create-widget-gl-context gtk) + (init!) + (let ([gl (gtk_widget_get_gl_context gtk)]) + (and gl + (new gl-context% + [gl gl] + [drawable (gtk_widget_get_gl_window gtk)])))) + + +(define-local-member-name + get-gdk-pixmap + install-gl-context) + +(define (create-and-install-gl-context bm config) + (init!) + (let ([config (config->GdkGLConfig #f config #f)]) + (when config + (let ([gdkpx (send bm get-gdk-pixmap)]) + (let ([glpx (gdk_pixmap_set_gl_capability gdkpx config #f)]) + (and glpx + (let ([gl + ;; currently uses "indirect" mode --- can we + ;; reliably use direct in some environments? + (gdk_gl_context_new glpx #f #f GDK_GL_RGBA_TYPE)]) + (and gl + (send bm install-gl-context + (new gl-context% + [gl gl] + [drawable glpx])))))))))) diff --git a/collects/mred/private/wx/gtk/group-panel.rkt b/collects/mred/private/wx/gtk/group-panel.rkt new file mode 100644 index 00000000..734feee3 --- /dev/null +++ b/collects/mred/private/wx/gtk/group-panel.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "window.rkt" + "client-window.rkt" + "panel.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out group-panel%)) + +(define-gtk gtk_frame_new (_fun _string -> _GtkWidget)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) + +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) + +(define-gtk gtk_frame_set_label (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_frame_get_label_widget (_fun _GtkWidget -> _GtkWidget)) + +(define group-panel% + (class (client-size-mixin (panel-mixin window%)) + (init parent + x y w h + style + label) + + (inherit set-size set-auto-size infer-client-delta + get-gtk get-height) + + (define gtk (as-gtk-allocation (gtk_frame_new label))) + (define client-gtk + (atomically (let ([client-gtk (gtk_fixed_new)]) + (gtk_container_add gtk client-gtk) + client-gtk))) + (gtk_widget_show client-gtk) + + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [extra-gtks (list client-gtk)] + [no-show? (memq 'deleted style)]) + + (infer-client-delta #t #t (gtk_frame_get_label_widget gtk)) + (set-auto-size) + + (define/public (set-label s) + (gtk_frame_set_label gtk s)) + + (define/override (get-client-gtk) client-gtk) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move client-gtk child-gtk x y) + (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/init.rkt b/collects/mred/private/wx/gtk/init.rkt new file mode 100644 index 00000000..ded4146b --- /dev/null +++ b/collects/mred/private/wx/gtk/init.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "queue.rkt") + +(define-gtk gtk_rc_parse_string (_fun _string -> _void)) +(define-gtk gtk_rc_add_default_file (_fun _path -> _void)) + +(when (eq? 'windows (system-type)) + (let ([dir (simplify-path (build-path (collection-path "racket") 'up 'up "lib"))]) + (gtk_rc_parse_string (format "module_path \"~a\"\n" dir)) + (gtk_rc_add_default_file (build-path dir "gtkrc")))) + +(define pump-thread (gtk-start-event-pump)) + diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt new file mode 100644 index 00000000..dbfd10bd --- /dev/null +++ b/collects/mred/private/wx/gtk/item.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw/private/local + "../../syntax.rkt" + "window.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out item% + install-control-font)) + +(define _PangoFontDescription _pointer) +(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void)) + +(define (install-control-font gtk font) + (when font + (gtk_widget_modify_font gtk (send font get-pango)))) + +(defclass item% window% + (inherit get-client-gtk) + + (init-field [callback void]) + (init [font #f]) + + (super-new) + + (let ([client-gtk (get-client-gtk)]) + (connect-focus client-gtk) + (connect-key-and-mouse client-gtk)) + (install-control-font (get-label-gtk) font) + + (define/public (get-label-gtk) (get-client-gtk)) + + (def/public-unimplemented set-label) + (def/public-unimplemented get-label) + + (define/public (command e) + (callback this e))) + + + + + diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt new file mode 100644 index 00000000..b5e7eb36 --- /dev/null +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -0,0 +1,68 @@ +#lang racket/base + +(provide map-key-code) + +(define (map-key-code v) + (hash-ref + #hash((#xff08 . #\backspace) + (#xffff . #\rubout) + (#xff09 . #\tab) + (#xff0a . #\newline) + (#xff0d . #\return) + (#xff1b . escape) ; escape + (#xff50 . home) + (#xff51 . left) + (#xff52 . up) + (#xff53 . right) + (#xff54 . down) + (#xff55 . prior) + (#xff56 . next) + (#xff57 . end) + (#xff80 . #\space) ; keypad + (#xff89 . #\tab) ; keypad + (#xff8d . #\u3) ; enter + (#xff91 . f1) + (#xff92 . f2) + (#xff93 . f3) + (#xff94 . f4) + (#xff95 . home) ; keypad + (#xff96 . left) ; keypd + (#xff97 . up) ; keypad + (#xff98 . right) ; keypad + (#xff99 . down) ; keypad + (#xff9a . prior) ; keypad + (#xff9b . next) ; keypad + (#xff9c . end) ; keypad + (#xff9e . insert) ; keypad + (#xff9f . #\rubout) ; keypad + (#xffaa . multiply) + (#xffab . add) + (#xffad . subtract) + (#xffaf . divide) + (#xffb0 . numpad0) + (#xffb1 . numpad1) + (#xffb2 . numpad2) + (#xffb3 . numpad3) + (#xffb4 . numpad4) + (#xffb5 . numpad5) + (#xffb6 . numpad6) + (#xffb7 . numpad7) + (#xffb8 . numpad8) + (#xffb9 . numpad9) + (#xffbe . f1) + (#xffbf . f2) + (#xffc0 . f3) + (#xffc1 . f4) + (#xffc2 . f5) + (#xffc3 . f6) + (#xffc4 . f7) + (#xffc5 . f8) + (#xffc6 . f9) + (#xffc7 . f10) + (#xffc8 . f11) + (#xffc9 . f12) + (#xffca . f13) + (#xffcb . f14) + (#xffcc . f15)) + v + #f)) diff --git a/collects/mred/private/wx/gtk/keymap.rkt b/collects/mred/private/wx/gtk/keymap.rkt new file mode 100644 index 00000000..80ff0c4e --- /dev/null +++ b/collects/mred/private/wx/gtk/keymap.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "const.rkt" + "types.rkt") + +(provide + (protect-out get-alts)) + +(define _GdkKeymap (_cpointer 'GdkKeymap)) + +(define-gdk gdk_keymap_get_default (_fun -> _GdkKeymap)) + +(define-gdk gdk_keymap_translate_keyboard_state + (_fun _GdkKeymap + _uint ; hardware_keycode + _int ; GdkModifierType state + _int ; group + (keyval : (_ptr o _uint)) + (effective_group : (_ptr o _int)) + (level : (_ptr o _int)) + (consumed_modifiers : (_ptr o _int)) + -> (r : _gboolean) + -> (and r keyval))) + +(define (get-alts event) + (define (get-one-alt mask) + (gdk_keymap_translate_keyboard_state (gdk_keymap_get_default) + (GdkEventKey-hardware_keycode event) + (let ([mods (GdkEventKey-state event)]) + (bitwise-ior (- mods (bitwise-and mods mask)) + (bitwise-and mask (bitwise-not (bitwise-and mods mask))))) + (GdkEventKey-group event))) + (let ([alt-gr? (eq? (= (bitwise-and (GdkEventKey-state event) GDK_CONTROL_MASK) + GDK_CONTROL_MASK) + (= (bitwise-and (GdkEventKey-state event) GDK_MOD1_MASK) + GDK_MOD1_MASK))]) + (values (get-one-alt GDK_SHIFT_MASK) + (and alt-gr? + (get-one-alt (bitwise-ior GDK_MOD1_MASK GDK_CONTROL_MASK))) + (and alt-gr? + (get-one-alt (bitwise-ior GDK_SHIFT_MASK GDK_MOD1_MASK GDK_CONTROL_MASK))) + (get-one-alt GDK_LOCK_MASK)))) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt new file mode 100644 index 00000000..a37a3401 --- /dev/null +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -0,0 +1,271 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + racket/class + (only-in racket/list take drop) + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt" + "../common/event.rkt") + +(provide + (protect-out list-box%)) + +;; ---------------------------------------- + +(define-cstruct _GtkTreeIter ([stamp _int] + [user_data _pointer] + [user_data2 _pointer] + [user_data3 _pointer])) + +(define _GtkListStore (_cpointer 'GtkListStore)) +(define _GtkCellRenderer (_cpointer 'GtkCellRenderer)) +(define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn) + +(define GTK_SELECTION_SINGLE 1) +(define GTK_SELECTION_MULTIPLE 3) + +(define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget)) +(define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) + +(define-gtk gtk_list_store_new (_fun _int _int -> _GtkListStore)) +(define-gtk gtk_list_store_clear (_fun _GtkListStore -> _void)) +(define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void)) +(define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) +(define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget)) +(define-gtk gtk_tree_view_set_headers_visible (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_cell_renderer_text_new (_fun -> _GtkCellRenderer)) +(define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) +(define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) +(define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) +(define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) +(define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) + +(define _GList (_cpointer 'List)) +(define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void)) +(define-glib g_list_free (_fun _GList -> _void)) +(define-gtk gtk_tree_selection_get_selected_rows (_fun _GtkWidget _pointer -> (_or-null _GList))) +(define-gtk gtk_tree_selection_path_is_selected (_fun _GtkWidget _pointer -> _gboolean)) +(define-gtk gtk_tree_selection_unselect_all (_fun _GtkWidget -> _void)) +(define-gtk gtk_tree_selection_select_path (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_tree_selection_unselect_path (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_tree_path_new_from_indices (_fun _int _int -> _pointer)) +(define-gtk gtk_tree_path_free (_fun _pointer -> _void)) +(define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) + +(define-gtk gtk_tree_view_get_visible_range (_fun _GtkWidget [sp : (_ptr o _pointer)] [ep : (_ptr o _pointer)] + -> [ok? : _gboolean] + -> (values (if ok? sp #f) (if ok? ep #f)))) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx queue-changed))))) + +(defclass list-box% item% + (init parent cb + label kind x y w h + choices style + font label-font) + (inherit get-gtk set-auto-size is-window-enabled?) + + (define items choices) + (define data (map (lambda (c) (box #f)) choices)) + + (define store (as-gobject-allocation (gtk_list_store_new 1 G_TYPE_STRING))) + (define (reset-content) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (for ([s (in-list items)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1))) + (maybe-init-select)) + + (define/private (maybe-init-select) + (when (and (= (get-selection) -1) + (pair? data)) + (set-selection 0))) + + (define gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f))) + (gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS) + + (define client-gtk + (atomically + (let* ([client-gtk (gtk_tree_view_new_with_model store)] + [column (let ([renderer (gtk_cell_renderer_text_new)]) + (gtk_tree_view_column_new_with_attributes + "column" + renderer + "text" + 0 + #f))]) + (gobject-unref store) + (gtk_tree_view_set_headers_visible client-gtk #f) + (gtk_tree_view_append_column client-gtk column) + client-gtk))) + + (gtk_container_add gtk client-gtk) + (gtk_widget_show client-gtk) + + (define selection + (gtk_tree_view_get_selection client-gtk)) + + (gtk_tree_selection_set_mode selection (if (or (eq? kind 'extended) + (eq? kind 'multiple)) + GTK_SELECTION_MULTIPLE + GTK_SELECTION_SINGLE)) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks (list client-gtk selection)] + [callback cb] + [font font] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + + (connect-changed selection) + + (define/override (get-client-gtk) client-gtk) + + (define callback cb) + (define ignore-click? #f) + (define/public (queue-changed) + (make-will-executor) + ;; Called from event-handling thread + (unless ignore-click? + (queue-window-event + this + (lambda () + (unless (null? items) + (callback this (new control-event% + [event-type 'list-box] + [time-stamp (current-milliseconds)]))))))) + + (define/private (get-iter i) + (atomically + (let ([iter (make-GtkTreeIter 0 #f #f #f)] + [p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_model_get_iter store iter p) + (gtk_tree_path_free p) + iter))) + + (def/public-unimplemented get-label-font) + + (define/public (set-string i s) + (set! items + (append (take items i) + (list s) + (drop items (add1 i)))) + (gtk_list_store_set store (get-iter i) 0 s -1)) + + (define/public (set-first-visible-item i) + (atomically + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0) + (gtk_tree_path_free p)))) + + (define/public (set choices) + (atomically + (set! ignore-click? #t) + (clear) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (reset-content) + (set! ignore-click? #f))) + + (define/public (get-selections) + (atomically + (let ([list (gtk_tree_selection_get_selected_rows selection #f)]) + (if list + (let ([v null]) + (g_list_foreach list + (lambda (t) + (set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int) + v))) + #f) + (g_list_foreach list gtk_tree_path_free #f) + (g_list_free list) + (reverse v)) + null)))) + (define/public (get-selection) + (let ([l (get-selections)]) + (if (null? l) + -1 + (car l)))) + + (define/private (get-visible-range) + (atomically + (let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)]) + (begin0 + (values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0) + (if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0)) + (when sp (gtk_tree_path_free sp)) + (when ep (gtk_tree_path_free ep)))))) + + (define/public (get-first-item) + (let-values ([(start end) (get-visible-range)]) + start)) + (define/public (number-of-visible-items) + (let-values ([(start end) (get-visible-range)]) + (add1 (- end start)))) + + (define/public (number) (length items)) + + (define/public (set-data i v) (set-box! (list-ref data i) v)) + (define/public (get-data i) (unbox (list-ref data i))) + + (define/public (selected? i) + (atomically + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (begin0 + (gtk_tree_selection_path_is_selected selection p) + (gtk_tree_path_free p))))) + + (define/public (select i [on? #t] [extend? #t]) + (atomically + (set! ignore-click? #t) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (if on? + (begin + (unless extend? + (gtk_tree_selection_unselect_all selection)) + (gtk_tree_selection_select_path selection p)) + (gtk_tree_selection_unselect_path selection p)) + (gtk_tree_path_free p)) + (set! ignore-click? #f))) + + (define/public (set-selection i) + (select i #t #f)) + + (define/public (delete i) + (set! items (append (take items i) (drop items (add1 i)))) + (set! data (append (take data i) (drop data (add1 i)))) + (gtk_list_store_remove store (get-iter i)) + (void)) + + (define/public (clear) + (set! items null) + (set! data null) + (gtk_list_store_clear store)) + + (public [append* append]) + (define (append* s [v #f]) + (atomically + (set! ignore-click? #t) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)) + (maybe-init-select) + (set! ignore-click? #f))) + + (atomically (reset-content))) diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt new file mode 100644 index 00000000..45ff8b43 --- /dev/null +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -0,0 +1,148 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" + "widget.rkt" + "window.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out menu-bar% + gtk_menu_item_new_with_mnemonic + gtk_menu_shell_append + fixup-mneumonic)) + +(define-gtk gtk_menu_bar_new (_fun -> _GtkWidget)) +(define-gtk gtk_menu_shell_append (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) +(define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-gtk gtk_widget_set_usize (_fun _GtkWidget _int _int -> _void)) + +(define (fixup-mneumonic title) + (regexp-replace* + "&&" + (regexp-replace* + #rx"&([^&])" + (regexp-replace* + #rx"_" + (regexp-replace #rx"\t.*$" title "") + "__") + "_\\1") + "&")) + +(define-signal-handler connect-select "select" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (let ([frame (send wx get-top-window)]) + (when frame + (constrained-reply (send frame get-eventspace) + (lambda () (send frame on-menu-click)) + (void)))))))) + +(define top-menu% + (class widget% + (init-field parent) + (define/public (get-top-window) (send parent get-top-window)) + (super-new))) + +(define-signal-handler connect-menu-key-press "key-press-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (or (not wx) + (other-modal? wx))))) + +(define-signal-handler connect-menu-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (or (not wx) + (other-modal? wx))))) + +(defclass menu-bar% widget% + (inherit install-widget-parent) + + (define menus null) + + (define gtk (as-gtk-allocation (gtk_menu_bar_new))) + (super-new [gtk gtk]) + + (define/public (get-gtk) gtk) + + (connect-menu-key-press gtk) + (connect-menu-button-press gtk) + + ; (gtk_menu_set_accel_group gtk the-accelerator-group) + + (define top-wx #f) + + (define/public (set-top-window top) + (set! top-wx top) + (install-widget-parent top) + ;; return initial size; also, add a menu to make sure there is one, + ;; and force the menu bar to be at least that tall always + (atomically + (let ([item (gtk_menu_item_new_with_mnemonic "Xyz")]) + (gtk_menu_shell_append gtk item) + (gtk_widget_show item) + (begin0 + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (gtk_widget_set_usize gtk -1 (GtkRequisition-height req)) + (GtkRequisition-height req)) + (gtk_container_remove gtk item))))) + + (define/public (get-top-window) + top-wx) + + (define/public (get-dialog-level) + (send top-wx get-dialog-level)) + + (define/public (set-label-top pos str) + (let ([l (list-ref menus pos)]) + (let ([item-gtk (car l)]) + (gtk_label_set_text_with_mnemonic (gtk_bin_get_child item-gtk) + (fixup-mneumonic str))))) + + (define/public (enable-top pos on?) + (gtk_widget_set_sensitive (car (list-ref menus pos)) on?)) + + (define/public (delete which pos) + (atomically + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) + (gtk_container_remove gtk (caar menus)) + (gtk_menu_item_set_submenu (caar menus) #f) + (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + (sub1 pos)))]))))) + + (public [append-menu append]) + (define (append-menu menu title) + (send menu set-parent this) + (atomically + (let* ([item (let ([title (fixup-mneumonic title)]) + (as-gtk-allocation + (gtk_menu_item_new_with_mnemonic title)))] + [item-wx (new top-menu% [parent this] [gtk item])]) + (connect-select item) + (set! menus (append menus (list (list item menu item-wx)))) + (let ([gtk (send menu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item gtk)) + (gtk_menu_shell_append gtk item) + (gtk_widget_show item))))) diff --git a/collects/mred/private/wx/gtk/menu-item.rkt b/collects/mred/private/wx/gtk/menu-item.rkt new file mode 100644 index 00000000..a6b6c342 --- /dev/null +++ b/collects/mred/private/wx/gtk/menu-item.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt") + +(provide + (protect-out menu-item%)) + +(defclass menu-item% object% + (define/public (id) this) + (super-new)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt new file mode 100644 index 00000000..732821bd --- /dev/null +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -0,0 +1,280 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "widget.rkt" + "window.rkt" + "../../syntax.rkt" + "../../lock.rkt" + "types.rkt" + "const.rkt" + "utils.rkt" + "menu-bar.rkt" + "../common/event.rkt") + +(provide + (protect-out menu%)) + +(define-gtk gtk_menu_new (_fun -> _GtkWidget)) +(define-gtk gtk_check_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) +(define-gtk gtk_separator_menu_item_new (_fun -> _GtkWidget)) +(define-gdk gdk_unicode_to_keyval (_fun _uint32 -> _uint)) +(define-gtk gtk_menu_item_set_accel_path (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_accel_map_add_entry (_fun _string _uint _int -> _void)) +(define-gtk gtk_check_menu_item_set_active (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_check_menu_item_get_active (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) + +(define-gtk gtk_get_current_event_time (_fun -> _uint32)) +(define-gtk gtk_menu_popup (_fun _GtkWidget _pointer _pointer + (_fun _GtkWidget _pointer _pointer _pointer -> _void) + _pointer _uint _uint32 + -> _void)) + +(define-signal-handler connect-menu-item-activate "activate" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx do-on-select))))) + +(define-signal-handler connect-menu-deactivate "deactivate" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx do-no-selected))))) + +(define menu-item-handler% + (class widget% + (init gtk) + (init-field menu + menu-item) + (super-new [gtk gtk]) + + (connect-menu-item-activate gtk) + + (define/public (get-item) menu-item) + + (define/public (removing-item) (void)) + + (define/public (do-on-select) + (send menu do-selected menu-item)) + + (define/public (on-select) + (send menu on-select-item menu-item)))) + +(define separator-item-handler% + (class object% + (define/public (get-item) #f) + (define/public (removing-item) (void)) + (super-new))) + +(defclass menu% widget% + (init label + callback + font) + + (inherit install-widget-parent) + + (define cb callback) + + (define gtk (as-gtk-allocation (gtk_menu_new))) + (define/public (get-gtk) gtk) + + (super-new [gtk gtk]) + + (connect-menu-deactivate gtk) + + (gtk_menu_set_accel_group gtk the-accelerator-group) + + (define items null) + + (define parent #f) + (define/public (set-parent p) + (set! parent p) + (install-widget-parent p)) + (define/public (get-top-parent) + ;; Maybe be called in Gtk event-handler thread + (and parent + (if (parent . is-a? . menu%) + (send parent get-top-parent) + (send parent get-top-window)))) + + (define self-item #f) + (define remover void) + (define/public (set-self-item i r) (set! self-item i) (set! remover r)) + (define/public (get-item) self-item) + (define/public (removing-item) + (set! self-item #f) + (remover) + (set! remover void)) + + (define on-popup #f) + (define cancel-none-box (box #t)) + + (define/public (popup x y queue-cb) + (set! on-popup queue-cb) + (set! cancel-none-box (box #f)) + (gtk_menu_popup gtk + #f + #f + (lambda (menu _x _y _push) + (ptr-set! _x _int x) + (ptr-set! _y _int y) + (ptr-set! _push _gboolean #t)) + #f + 0 + (gtk_get_current_event_time))) + + (define ignore-callback? #f) + + (define/public (do-selected menu-item) + ;; Called in event-pump thread + (unless ignore-callback? + (let ([top (get-top-parent)]) + (cond + [top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))] + [on-popup + (let* ([e (new popup-event% [event-type 'menu-popdown])] + [pu on-popup] + [cnb cancel-none-box]) + (set! on-popup #f) + (set-box! cancel-none-box #t) + (send e set-menu-id menu-item) + (pu (lambda () (cb this e))))] + [parent (send parent do-selected menu-item)])))) + + (define/public (do-no-selected) + ;; Queue a none-selected event, but only tentatively, because + ;; the selection event may come later and cancel the none-selected + ;; event. + (when on-popup + (let* ([e (new popup-event% [event-type 'menu-popdown])] + [pu on-popup] + [cnb cancel-none-box]) + (send e set-menu-id #f) + (pu (lambda () + (when (eq? on-popup pu) + (set! on-popup #f)) + (unless (unbox cnb) + (cb this e))))))) + + (define/private (adjust-shortcut item-gtk title) + (cond + [(regexp-match #rx"\tCtrl[+](.)$" title) + => (lambda (m) + (let ([code (gdk_unicode_to_keyval + (char->integer + (string-ref (cadr m) 0)))]) + (unless (zero? code) + (let ([accel-path (format "/Hardwired/~a" title)]) + (gtk_accel_map_add_entry accel-path + code + GDK_CONTROL_MASK) + (gtk_menu_item_set_accel_path item-gtk accel-path)))))])) + + (public [append-item append]) + (define (append-item i label help-str-or-submenu chckable?) + (atomically + (let ([item-gtk (let ([label (fixup-mneumonic label)]) + (as-gtk-allocation + ((if (and chckable? + (not (help-str-or-submenu . is-a? . menu%))) + gtk_check_menu_item_new_with_mnemonic + gtk_menu_item_new_with_mnemonic) + label)))]) + (if (help-str-or-submenu . is-a? . menu%) + (let ([submenu help-str-or-submenu]) + (let ([gtk (send submenu get-gtk)]) + (g_object_ref gtk) + (gtk_menu_item_set_submenu item-gtk gtk) + (send submenu set-parent this) + (send submenu set-self-item i + (lambda () (gtk_menu_item_set_submenu item-gtk #f))) + (set! items (append items (list (list submenu item-gtk label chckable?)))))) + (let ([item (new menu-item-handler% + [gtk item-gtk] + [menu this] + [menu-item i] + [parent this])]) + (set! items (append items (list (list item item-gtk label chckable?)))) + (adjust-shortcut item-gtk label))) + (gtk_menu_shell_append gtk item-gtk) + (gtk_widget_show item-gtk)))) + + (define/public (append-separator) + (atomically + (let ([item-gtk (as-gtk-allocation (gtk_separator_menu_item_new))]) + (set! items (append items (list (list (new separator-item-handler%) item-gtk #f #f)))) + (gtk_menu_shell_append gtk item-gtk) + (gtk_widget_show item-gtk)))) + + (def/public-unimplemented select) + (def/public-unimplemented get-font) + (def/public-unimplemented set-width) + (def/public-unimplemented set-title) + + (define/public (set-help-string m s) (void)) + + (define/public (number) (length items)) + + (define/private (find-gtk item) + (for/or ([i items]) + (and (car i) + (eq? (send (car i) get-item) item) + (cadr i)))) + + (define/public (set-label item str) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk) + (fixup-mneumonic str))))) + + (define/public (enable item on?) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_widget_set_sensitive gtk on?)))) + + (define/public (check item on?) + (let ([gtk (find-gtk item)]) + (when gtk + (atomically + (set! ignore-callback? #t) + (gtk_check_menu_item_set_active gtk on?) + (set! ignore-callback? #f))))) + + (define/public (checked? item) + (let ([gtk (find-gtk item)]) + (when gtk + (gtk_check_menu_item_get_active gtk)))) + + (define/public (delete-by-position pos) + (set! items + (let loop ([items items] + [pos pos]) + (cond + [(null? items) null] + [(zero? pos) + (send (caar items) removing-item) + (gtk_container_remove gtk (cadar items)) + (cdr items)] + [else (cons (car items) + (loop (cdr items) (sub1 pos)))])))) + + (define/public (delete item) + (set! items + (let loop ([items items]) + (cond + [(null? items) null] + [(eq? (send (caar items) get-item) item) + (send (caar items) removing-item) + (gtk_container_remove gtk (cadar items)) + (cdr items)] + [else (cons (car items) + (loop (cdr items)))]))))) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt new file mode 100644 index 00000000..587f3291 --- /dev/null +++ b/collects/mred/private/wx/gtk/message.rkt @@ -0,0 +1,89 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "pixbuf.rkt") + +(provide + (protect-out message% + + gtk_label_new_with_mnemonic + gtk_label_set_text_with_mnemonic + mnemonic-string)) + +;; ---------------------------------------- + +(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) +(define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) +(define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) +(define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void)) + +(define (mnemonic-string s) + (if (regexp-match? #rx"&" s) + (regexp-replace* + #rx"_&" + (regexp-replace* + #rx"&(.)" + (regexp-replace* #rx"_" s "__") + "_\\1") + "\\&") + (regexp-replace* #rx"_" s "__"))) + +(define (gtk_label_new_with_mnemonic s) + (let ([l (gtk_label_new s)]) + (when (regexp-match? #rx"&" s) + (let ([s (mnemonic-string s)]) + (gtk_label_set_text_with_mnemonic l s))) + l)) + +(define icon-size 6) ; = GTK_ICON_SIZE_DIALOG + +(defclass message% item% + (init parent label + x y + style font) + (inherit set-auto-size get-gtk) + + (super-new [parent parent] + [gtk (if (or (string? label) + (not label)) + (as-gtk-allocation (gtk_label_new_with_mnemonic (or label ""))) + (if (symbol? label) + (as-gtk-allocation + (case label + [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] + [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] + [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])) + (if (send label ok?) + (let ([pixbuf (bitmap->pixbuf label)]) + (begin0 + (as-gtk-allocation + (gtk_image_new_from_pixbuf pixbuf)) + (release-pixbuf pixbuf))) + (as-gtk-allocation + (gtk_label_new_with_mnemonic "")))))] + [font font] + [no-show? (memq 'deleted style)]) + + (when (string? label) + (gtk_misc_set_alignment (get-gtk) 0.0 0.0)) + + (set-auto-size) + + (define/override (set-label s) + (cond + [(string? s) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] + [else + (let ([pixbuf (bitmap->pixbuf s)]) + (atomically + (gtk_image_set_from_pixbuf (get-gtk) pixbuf) + (release-pixbuf pixbuf)))])) + + (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt new file mode 100644 index 00000000..280ad9aa --- /dev/null +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -0,0 +1,88 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "window.rkt" + "utils.rkt" + "types.rkt" + "const.rkt") + +(provide + (protect-out panel% + panel-mixin)) + +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) +(define-gtk gtk_event_box_new (_fun -> _GtkWidget)) + +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) + +(define (panel-mixin %) + (class % + + (define lbl-pos 'horizontal) + (define children null) + + (super-new) + + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (define/override (reset-child-dcs) + (when (pair? children) + (for ([child (in-list children)]) + (send child reset-child-dcs)))) + + (define/override (paint-children) + (when (pair? children) + (for ([child (in-list children)]) + (send child paint-children)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (reset-child-dcs)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) + + (define/public (set-item-cursor x y) (void)))) + +(define panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) + + (inherit set-size get-gtk) + + (define gtk (as-gtk-allocation (gtk_event_box_new))) + (define client-gtk (atomically + (let ([client (gtk_fixed_new)]) + (gtk_container_add gtk client) + (gtk_widget_show client) + client))) + + (define/override (get-client-gtk) client-gtk) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks (list client-gtk)] + [no-show? (memq 'deleted style)]) + + (connect-key-and-mouse gtk) + (gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move client-gtk child-gtk x y) + (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt new file mode 100644 index 00000000..d5c2733c --- /dev/null +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -0,0 +1,82 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc + racket/draw + racket/draw/private/local + racket/draw/unsafe/cairo + "../../lock.rkt" + racket/draw/unsafe/bstr + "utils.rkt" + "types.rkt" + (only-in '#%foreign ffi-callback)) + +(provide + (protect-out bitmap->pixbuf + pixbuf->bitmap + + _GdkPixbuf + gtk_image_new_from_pixbuf + release-pixbuf)) + +(define _GdkPixbuf (_cpointer/null 'GdkPixbuf)) + +(define release-pixbuf ((deallocator) g_object_unref)) + +(define-gtk gtk_image_new_from_pixbuf (_fun _GdkPixbuf -> _GtkWidget)) +(define-gdk_pixbuf gdk_pixbuf_new_from_data (_fun _pointer ; data + _int ; 0 =RGB + _gboolean ; has_alpha? + _int ; bits_per_sample + _int ; width + _int ; height + _int ; rowstride + _fpointer ; destroy + _pointer ; destroy data + -> _GdkPixbuf) + #:wrap (allocator release-pixbuf)) + +(define-gdk gdk_cairo_set_source_pixbuf (_fun _cairo_t _GdkPixbuf _double* _double* -> _void)) +(define-gdk gdk_pixbuf_get_width (_fun _GdkPixbuf -> _int)) +(define-gdk gdk_pixbuf_get_height (_fun _GdkPixbuf -> _int)) + +(define free-it (ffi-callback free + (list _pointer) + _void + #f + #t)) + +(define (bitmap->pixbuf bm) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [str (make-bytes (* w h 4) 255)]) + (send bm get-argb-pixels 0 0 w h str #f) + (let ([mask (send bm get-loaded-mask)]) + (when mask + (send mask get-argb-pixels 0 0 w h str #t))) + (atomically + (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) + (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) + (for ([i (in-range 0 (* w h 4) 4)]) + (bytes-set! rgba (+ i 3) (bytes-ref str i))) + (gdk_pixbuf_new_from_data rgba + 0 + #t + 8 + w + h + (* w 4) + free-it + #f))))) + +(define (pixbuf->bitmap pixbuf) + (let* ([w (gdk_pixbuf_get_width pixbuf)] + [h (gdk_pixbuf_get_height pixbuf)] + [bm (make-object bitmap% w h #f #t)] + [s (send bm get-cairo-surface)] + [cr (cairo_create s)]) + (gdk_cairo_set_source_pixbuf cr pixbuf 0 0) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr) + (cairo_destroy cr) + bm)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt new file mode 100644 index 00000000..0abd4fa3 --- /dev/null +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -0,0 +1,90 @@ +#lang racket/base +(require "init.rkt" + "button.rkt" + "canvas.rkt" + "check-box.rkt" + "choice.rkt" + "clipboard.rkt" + "cursor.rkt" + "dialog.rkt" + "frame.rkt" + "gauge.rkt" + "group-panel.rkt" + "item.rkt" + "list-box.rkt" + "menu.rkt" + "menu-bar.rkt" + "menu-item.rkt" + "message.rkt" + "panel.rkt" + "printer-dc.rkt" + "radio-box.rkt" + "slider.rkt" + "tab-panel.rkt" + "window.rkt" + "procs.rkt") +(provide + (protect-out platform-values)) + +(define (platform-values) + (values + button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + has-x-selection? + hide-cursor + bell + display-size + display-origin + flush-display + fill-private-color + cancel-quit + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + get-double-click-time + run-printout + file-creator-and-type + location->window + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + find-graphical-system-path + play-sound + get-panel-background + font-from-user-platform-mode + get-font-from-user + color-from-user-platform-mode + get-color-from-user + special-option-key + special-control-key + get-highlight-background-color + get-highlight-text-color + make-screen-bitmap + make-gl-bitmap + check-for-break)) diff --git a/collects/mred/private/wx/gtk/printer-dc.rkt b/collects/mred/private/wx/gtk/printer-dc.rkt new file mode 100644 index 00000000..92980523 --- /dev/null +++ b/collects/mred/private/wx/gtk/printer-dc.rkt @@ -0,0 +1,230 @@ +#lang racket/base +(require racket/class + racket/draw/private/local + racket/draw/private/dc + racket/draw/unsafe/cairo + racket/draw/private/bitmap + racket/draw/private/bitmap-dc + racket/draw/private/record-dc + racket/draw/private/ps-setup + ffi/unsafe + ffi/unsafe/alloc + "../common/queue.rkt" + "widget.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out printer-dc% + show-print-setup)) + +(define GTK_UNIT_POINTS 1) + +(define GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG 0) + +(define GTK_PRINT_OPERATION_RESULT_ERROR 0) +(define GTK_PRINT_OPERATION_RESULT_APPLY 1) +(define GTK_PRINT_OPERATION_RESULT_CANCEL 2) +(define GTK_PRINT_OPERATION_RESULT_IN_PROGRESS 3) + +(define GTK_PAGE_ORIENTATION_PORTRAIT 0) +(define GTK_PAGE_ORIENTATION_LANDSCAPE 1) +(define GTK_PAGE_ORIENTATION_REVERSE_PORTRAIT 2) +(define GTK_PAGE_ORIENTATION_REVERSE_LANDSCAPE 3) + +(define _GtkPageSetup (_cpointer/null 'GtkPageSetup)) +(define _GtkPrintSettings (_cpointer/null 'GtkPrintSettings)) +(define _GtkPrintOperation _GtkWidget) ; not really, but we connect signals... +(define _GtkPrintContext (_cpointer/null 'GtkPrintContext)) + +(define-gtk gtk_page_setup_new (_fun -> _GtkPageSetup) + #:wrap (allocator gobject-unref)) +(define-gtk gtk_page_setup_copy (_fun _GtkPageSetup -> _GtkPageSetup) + #:wrap (allocator gobject-unref)) +(define allocated-page-setup ((allocator gobject-unref) values)) + +(define-gtk gtk_print_settings_new (_fun -> _GtkPrintSettings) + #:wrap (allocator gobject-unref)) + +(define-gtk gtk_page_setup_get_paper_height (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_paper_width (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_left_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_right_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_top_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_bottom_margin (_fun _GtkPageSetup _int -> _double)) + +(define-gtk gtk_page_setup_get_orientation (_fun _GtkPageSetup -> _int)) +(define-gtk gtk_page_setup_set_orientation (_fun _GtkPageSetup _int -> _void)) + +(define-gtk gtk_print_operation_new (_fun -> _GtkPrintOperation) + #:wrap (allocator gobject-unref)) + +(define-gtk gtk_print_operation_set_default_page_setup (_fun _GtkPrintOperation _GtkPageSetup + -> _void)) +(define-gtk gtk_print_operation_run (_fun _GtkPrintOperation + _int + (_or-null _GtkWindow) + (_ptr o _pointer) + -> _int)) + +(define-gtk gtk_print_operation_set_allow_async (_fun _GtkPrintOperation _gboolean -> _void)) +(define-gtk gtk_print_operation_set_n_pages (_fun _GtkPrintOperation _int -> _void)) + +(define-gtk gtk_print_context_get_cairo_context (_fun _GtkPrintContext -> _cairo_t)) + +(define-gtk gtk_print_run_page_setup_dialog_async (_fun (_or-null _GtkWindow) + _GtkPageSetup + _GtkPrintSettings + _fpointer + _pointer + -> _void)) + +(define (print-setup-done page-setup cb) + ((ptr-ref cb _racket) page-setup)) +(define print_setup_done (function-ptr print-setup-done + (_fun _GtkPageSetup _pointer -> _void))) + +(define (pss-install-page-setup pss page-setup) + (gtk_page_setup_set_orientation page-setup (if (eq? (send pss get-orientation) 'landscape) + GTK_PAGE_ORIENTATION_LANDSCAPE + GTK_PAGE_ORIENTATION_PORTRAIT))) + +(define (show-print-setup parent) + (let* ([pss (current-ps-setup)] + [page-setup (or (send pss get-native) + (let ([ps (gtk_page_setup_new)]) + (send pss set-native ps gtk_page_setup_copy) + ps))] + [print-settings (gtk_print_settings_new)] + [sema (make-semaphore)] + [done-page-setup #f] + [cell (malloc-immobile-cell (lambda (ps) + (set! done-page-setup (and ps + (allocated-page-setup ps))) + (semaphore-post sema)))]) + (pss-install-page-setup pss page-setup) + (gtk_print_run_page_setup_dialog_async (and parent + (send parent get-gtk)) + page-setup + print-settings + print_setup_done + cell) + (yield sema) + ;; `ptr-set!'s are a hack to ensure that the objects are not GCed: + (ptr-set! cell _racket page-setup) + (ptr-set! cell _racket print-settings) + (free-immobile-cell cell) + (and done-page-setup + (begin + (send pss set-native done-page-setup gtk_page_setup_copy) + (send pss set-orientation (if (member + (gtk_page_setup_get_orientation done-page-setup) + (list GTK_PAGE_ORIENTATION_LANDSCAPE + GTK_PAGE_ORIENTATION_REVERSE_LANDSCAPE)) + 'landscape + 'portrait)) + #t)))) + +(define-signal-handler connect-begin-print "begin-print" + (_fun _GtkPrintOperation _GtkPrintContext -> _void) + (lambda (op-gtk ctx-gtk) + (void))) + +(define-signal-handler connect-draw-page "draw-page" + (_fun _GtkPrintOperation _GtkPrintContext _int -> _void) + (lambda (op-gtk ctx-gtk page-no) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx draw-page ctx-gtk page-no))))) + +(define-signal-handler connect-done "done" + (_fun _GtkPrintOperation _int -> _void) + (lambda (op-gtk res) + (when (= res GTK_PRINT_OPERATION_RESULT_CANCEL) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx done)))))) + +(define-signal-handler connect-end-print "end-print" + (_fun _GtkPrintOperation _GtkPrintContext -> _void) + (lambda (op-gtk ctx-gtk) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx done))))) + +(define printout% + (class widget% + (init-field op-gtk + pages + page-setup) + (super-new [gtk op-gtk]) + + (connect-begin-print op-gtk) + (connect-draw-page op-gtk) + (connect-done op-gtk) + (connect-end-print op-gtk) + + (gtk_print_operation_set_n_pages op-gtk (length pages)) + (gtk_print_operation_set_allow_async op-gtk #t) + (gtk_print_operation_set_default_page_setup op-gtk page-setup) + + (define done-sema (make-semaphore)) + + (define/public (go) + (let ([res (gtk_print_operation_run op-gtk + GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG + #f)]) + (yield done-sema))) + + (define/public (draw-page ctx-gtk pageno) + (let ([cr (gtk_print_context_get_cairo_context ctx-gtk)]) + ((list-ref pages pageno) + (make-object + (class (dc-mixin default-dc-backend%) + (super-new) + (define orig-matrix (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)) + (cairo_get_matrix cr orig-matrix) + (define/override (init-cr-matrix cr) (cairo_set_matrix cr orig-matrix)) + (define/override (get-cr) cr)))))) + + (define/public (done) + (semaphore-post done-sema)))) + +(define printer-dc% + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object bitmap% 1 1)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define page-setup (or (let-values ([(ps copier) + (send (current-ps-setup) + get-native-copy)]) + ps) + (gtk_page_setup_new))) + (pss-install-page-setup (current-ps-setup) page-setup) + + (define page-width (- (gtk_page_setup_get_paper_width page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_left_margin page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_right_margin page-setup GTK_UNIT_POINTS))) + (define page-height (- (gtk_page_setup_get_paper_height page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_top_margin page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_bottom_margin page-setup GTK_UNIT_POINTS))) + (define page-scaling 1.0) ; scale from gtk_print_operation_run is too late + + (define/override (get-size) + (values (/ page-width page-scaling) (/ page-height page-scaling))) + + (define/override (end-doc) + (send (new printout% + [op-gtk (gtk_print_operation_new)] + [pages (reverse pages)] + [page-setup page-setup]) + go)))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt new file mode 100644 index 00000000..1dc5c903 --- /dev/null +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -0,0 +1,159 @@ +#lang racket/base +(require ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + racket/class + racket/draw + "filedialog.rkt" + "colordialog.rkt" + "types.rkt" + "utils.rkt" + "style.rkt" + "widget.rkt" + "window.rkt" + "frame.rkt" + "dc.rkt" + "queue.rkt" + "printer-dc.rkt" + "gl-context.rkt" + "../common/printer.rkt" + "../common/default-procs.rkt" + "../common/handlers.rkt") + +(provide + (protect-out + color-from-user-platform-mode + get-font-from-user + font-from-user-platform-mode + play-sound + find-graphical-system-path + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + run-printout + get-double-click-time + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + cancel-quit + bell + hide-cursor + get-display-depth + is-color-display? + id-to-menu-item + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color + check-for-break) + file-selector + show-print-setup + display-origin + display-size + flush-display + location->window + make-screen-bitmap + make-gl-bitmap + file-creator-and-type + special-control-key + special-option-key + get-panel-background + fill-private-color + get-color-from-user) + +(define (find-graphical-system-path what) + (case what + [(x-display) (string->path x11-display)] + [else #f])) + +(define (cancel-quit) (void)) + +(define-unimplemented play-sound) + +(define (color-from-user-platform-mode) + (and (color-dialog-works?) + 'dialog)) + +(define (font-from-user-platform-mode) #f) +(define-unimplemented get-font-from-user) + +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) +(define (shortcut-visible-in-label? [mbar? #f]) #t) + +(define run-printout (make-run-printout printer-dc%)) + +(define _GtkSettings (_cpointer 'GtkSettings)) +(define-gtk gtk_settings_get_default (_fun -> _GtkSettings)) +(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) +(define-gobj g_object_get/string (_fun _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) + +(define (get-double-click-time) + (let ([s (gtk_settings_get_default)]) + (if s + (g_object_get/int s "gtk-double-click-time") + 250))) +(define (get-control-font proc default) + (or + (let ([s (gtk_settings_get_default)]) + (and s + (let ([f (g_object_get/string s "gtk-font-name")]) + (and f + (begin0 + (cond + [(regexp-match #rx"^(.*) ([0-9]+)$" (cast f _pointer _string)) + => (lambda (m) (proc (cdr m)))] + [else #f]) + (g_free f)))))) + default)) +(define (get-control-font-size) + (get-control-font (lambda (m) (string->number (cadr m))) + 10)) +(define (get-control-font-face) + (get-control-font (lambda (m) (car m)) + "Sans")) +(define (get-control-font-size-in-pixels?) #f) + +(define (get-display-depth) 32) + +(define-gdk gdk_display_beep (_fun _GdkDisplay -> _void)) +(define (bell) (gdk_display_beep (gdk_display_get_default))) + +(define (hide-cursor) (void)) + +(define (is-color-display?) #t) + +(define (id-to-menu-item i) i) +(define (can-show-print-setup?) #t) + +(define (get-highlight-background-color) + (let-values ([(r g b) (get-selected-background-color)]) + (make-object color% r g b))) + +(define (get-highlight-text-color) + (let-values ([(r g b) (get-selected-text-color)]) + (if (and (zero? r) (zero? g) (zero? b)) + #f + (make-object color% r g b)))) + +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (if (eq? 'unix (system-type)) + (make-object x11-bitmap% w h #f) + (make-object bitmap% w h #f #t))) + +(define/top (make-gl-bitmap [exact-positive-integer? w] + [exact-positive-integer? h] + [gl-config% c]) + (let ([bm (make-object x11-bitmap% w h #f)]) + (create-and-install-gl-context bm c) + bm)) + +(define (check-for-break) #f) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt new file mode 100644 index 00000000..110e8932 --- /dev/null +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -0,0 +1,221 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "utils.rkt" + "types.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "../common/freeze.rkt" + "clipboard.rkt" + "const.rkt" + "w32.rkt" + "unique.rkt") + +(provide (protect-out gtk-start-event-pump + try-to-sync-refresh + set-widget-hook! + x11-display) + ;; from common/queue: + current-eventspace + queue-event + yield) + + +;; ------------------------------------------------------------ +;; Gtk initialization + +(define-gtk gtk_init_check (_fun (_ptr io _int) (_ptr io _gcpointer) -> _gboolean)) + +(define x11-display + (let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)] + [argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)] + [argv (and (positive? argc) + (scheme_register_process_global "PLT_X11_ARGUMENTS" #f))] + [display (getenv "DISPLAY")]) + ;; Convert X11 arguments, if any, to Gtk form: + (let-values ([(args single-instance?) + (if (zero? argc) + (values null #f) + (let loop ([i 1][si? #f]) + (if (= i argc) + (values null si?) + (let ([s (ptr-ref argv _bytes i)]) + (cond + [(bytes=? s #"-display") + (let-values ([(args si?) (loop (+ i 2) si?)] + [(d) (ptr-ref argv _bytes (add1 i))]) + (set! display (bytes->string/utf-8 d #\?)) + (values (list* #"--display" d args) + si?))] + [(bytes=? s #"-synchronous") + (let-values ([(args si?) (loop (+ i 1) si?)]) + (values (cons #"--sync" args) + si?))] + [(bytes=? s #"-singleInstance") + (loop (add1 i) #t)] + [(or (bytes=? s #"-iconic") + (bytes=? s #"-rv") + (bytes=? s #"+rv") + (bytes=? s #"-reverse")) + ;; ignored with 0 arguments + (loop (add1 i) #t)] + [else + ;; all other ignored flags have a single argument + (loop (+ i 2) #t)])))))]) + (let-values ([(new-argc new-argv) + (if (null? args) + (values 0 #f) + (values (add1 (length args)) + (cast (cons (ptr-ref argv _bytes 0) + args) + (_list i _bytes) + _pointer)))]) + (unless (gtk_init_check new-argc new-argv) + (error (format + "Gtk initialization failed for display ~s" + (or display ":0")))) + (when single-instance? + (do-single-instance)) + display)))) + +;; ------------------------------------------------------------ +;; Gtk event pump + +(define-gtk gtk_events_pending (_fun -> _gboolean)) +(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean)) + +(define _GMainContext (_cpointer 'GMainContext)) +(define _GdkEvent (_cpointer 'GdkEvent)) + +(define-cstruct _GPollFD ([fd _int] + [events _short] + [revents _short])) + +(define-glib g_main_context_default (_fun -> _GMainContext)) +(define-glib g_main_context_query (_fun _GMainContext + _int + _pointer + _pointer ;; GPollFD array + _int + -> _int)) + +(define-gdk gdk_event_handler_set (_fun (_fun _GdkEvent _pointer -> _void) + _pointer + (_fun _pointer -> _void) + -> _void)) +(define-gdk gdk_event_copy (_fun _GdkEvent -> _GdkEvent)) +(define-gdk gdk_event_free (_fun _GdkEvent -> _void)) +(define-gtk gtk_main_do_event (_fun _GdkEvent -> _void)) +(define-gtk gtk_get_event_widget (_fun _GdkEvent -> (_or-null _GtkWidget))) + +(define poll-fd-count 1) +(define poll-fds (make-GPollFD 0 0 0)) +(define timeout (malloc _int)) + +;; These are OS-specific, but they tend to be the same across OSes: +(define POLLIN #x1) +(define POLLOUT #x4) +(define POLLERR #x8) +(define POLLHUP #x10) + +(define-mz scheme_get_fdset (_fun _pointer _int -> _pointer)) +(define-mz scheme_fdset (_fun _pointer _int -> _void)) +(define-mz scheme_set_wakeup_time (_fun _pointer _double -> _void)) +(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void) + #:fail #f) + +(define (install-wakeup fds) + (let ([n (g_main_context_query (g_main_context_default) + #x7FFFFFFF ; max-int, hopefully + timeout + poll-fds + poll-fd-count)]) + (let ([to (ptr-ref timeout _int)]) + (when (to . >= . 0) + (scheme_set_wakeup_time fds (+ (current-inexact-milliseconds) to)))) + (if (n . > . poll-fd-count) + (begin + (set! poll-fds (malloc _GPollFD n)) + (set! poll-fd-count n) + (install-wakeup fds)) + (if (eq? 'windows (system-type)) + ;; We don't know how to deal with GLib FDs under + ;; Windows, but we should wake up on any Windows event + (scheme_add_fd_eventmask fds QS_ALLINPUT) + ;; Normal FD handling under Unix variants: + (for ([i (in-range n)]) + (let* ([gfd (ptr-ref poll-fds _GPollFD i)] + [fd (GPollFD-fd gfd)] + [events (GPollFD-events gfd)]) + (when (not (zero? (bitwise-and events POLLIN))) + (scheme_fdset (scheme_get_fdset fds 0) fd)) + (when (not (zero? (bitwise-and events POLLOUT))) + (scheme_fdset (scheme_get_fdset fds 1) fd)) + (when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP)))) + (scheme_fdset (scheme_get_fdset fds 2) fd)))))))) + +(set-check-queue! gtk_events_pending) +(set-queue-wakeup! install-wakeup) + +(define widget-hook (lambda (gtk) #f)) +(define (set-widget-hook! proc) (set! widget-hook proc)) + +(define (event-dispatch evt ignored) + (let* ([gtk (gtk_get_event_widget evt)] + [wx (and gtk (widget-hook gtk))]) + (cond + [(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE) + wx + (send wx direct-update?)) + (gtk_main_do_event evt)] + [(or + ;; event for a window that we control? + (and wx (send wx get-eventspace)) + ;; event to get X selection data? + (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) + => (lambda (e) + (let ([evt (gdk_event_copy evt)]) + (queue-event e (lambda () + (call-as-nonatomic-retry-point + (lambda () + (gtk_main_do_event evt) + (gdk_event_free evt)))))))] + [else + (gtk_main_do_event evt)]))) +(define (uninstall ignored) + (printf "uninstalled!?\n")) + +(gdk_event_handler_set event-dispatch + #f + uninstall) + +(define (dispatch-all-ready) + (pre-event-sync #f) + (clean-up-destroyed) + (when (gtk_events_pending) + (gtk_main_iteration_do #f) + (dispatch-all-ready))) + +(define-gdk gdk_window_process_all_updates (_fun -> _void)) + +(define (gtk-start-event-pump) + (thread (lambda () + (let loop () + (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) + (sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001)) + queue-evt + (if any-tasks? + (wrap-evt (system-idle-evt) + (lambda (v) #f)) + boundary-tasks-ready-evt))) + (pre-event-sync #t)) + (atomically (dispatch-all-ready)) + (loop))))) + +(define (try-to-sync-refresh) + (atomically + (pre-event-sync #t))) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt new file mode 100644 index 00000000..446c410a --- /dev/null +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -0,0 +1,133 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "item.rkt" + (except-in "utils.rkt" _GSList) + "types.rkt" + "widget.rkt" + "window.rkt" + "pixbuf.rkt" + "message.rkt" + "../common/event.rkt" + "../../lock.rkt") + +(provide + (protect-out radio-box%)) + +;; ---------------------------------------- + +(define _GSList (_cpointer/null 'GSList)) + +(define-gtk gtk_radio_button_new_with_mnemonic (_fun _GSList _string -> _GtkWidget)) +(define-gtk gtk_radio_button_new (_fun _GSList -> _GtkWidget)) +(define-gtk gtk_radio_button_get_group (_fun _GtkWidget -> _GSList)) +(define-gtk gtk_radio_button_set_group (_fun _GtkWidget _GSList -> _void)) +(define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-signal-handler connect-clicked "clicked" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx queue-clicked))))) + +(defclass radio-box% item% + (init parent cb label + x y w h + labels + val + style + font) + (inherit set-auto-size + on-set-focus) + + (define gtk (as-gtk-allocation + (if (memq 'horizontal style) + (gtk_hbox_new #f 0) + (gtk_vbox_new #f 0)))) + (define radio-gtks (for/list ([lbl (in-list labels)]) + (atomically + (let ([radio-gtk (cond + [(string? lbl) + (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] + [(send lbl ok?) + (let ([pixbuf (bitmap->pixbuf lbl)]) + (let ([radio-gtk (gtk_radio_button_new #f)] + [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) + (release-pixbuf pixbuf) + (gtk_container_add radio-gtk image-gtk) + (gtk_widget_show image-gtk) + radio-gtk))] + [else + (gtk_radio_button_new_with_mnemonic #f "")])]) + (gtk_box_pack_start gtk radio-gtk #t #t 0) + (install-control-font (gtk_bin_get_child radio-gtk) font) + (gtk_widget_show radio-gtk) + radio-gtk)))) + (for ([radio-gtk (in-list (cdr radio-gtks))]) + (let ([g (gtk_radio_button_get_group (car radio-gtks))]) + (gtk_radio_button_set_group radio-gtk g))) + + (define dummy-gtk #f) + + (super-new [parent parent] + [gtk gtk] + [extra-gtks radio-gtks] + [callback cb] + [no-show? (memq 'deleted style)]) + + (set-auto-size) + (for ([radio-gtk (in-list radio-gtks)]) + (connect-clicked radio-gtk) + (connect-key-and-mouse radio-gtk) + (connect-focus radio-gtk)) + + (define callback cb) + (define/public (clicked) + (callback this (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))) + (define no-clicked? #f) + (define/public (queue-clicked) + (unless no-clicked? + (queue-window-event this (lambda () (clicked))))) + + (define/public (button-focus i) + (if (= i -1) + (or (for/or ([radio-gtk (in-list radio-gtks)] + [i (in-naturals)]) + (and (gtk_widget_is_focus radio-gtk) + i)) + 0) + (gtk_widget_grab_focus (list-ref radio-gtks i)))) + (define/override (set-focus) + (button-focus (max 0 (set-selection)))) + (define/public (set-selection i) + (atomically + (set! no-clicked? #t) + (if (= i -1) + (when (pair? radio-gtks) + (unless dummy-gtk + (set! dummy-gtk (as-gtk-allocation + (gtk_radio_button_new + (gtk_radio_button_get_group (car radio-gtks)))))) + (gtk_toggle_button_set_active dummy-gtk #t)) + (gtk_toggle_button_set_active (list-ref radio-gtks i) #t)) + (set! no-clicked? #f))) + + (define/public (get-selection) + (or (for/or ([radio-gtk (in-list radio-gtks)] + [i (in-naturals)]) + (and (gtk_toggle_button_get_active radio-gtk) + i)) + -1)) + + (define/public (enable-button i on?) + (gtk_widget_set_sensitive (list-ref radio-gtks i) on?)) + + (define count (length labels)) + (define/public (number) count)) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt new file mode 100644 index 00000000..b120a29a --- /dev/null +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "window.rkt" + "const.rkt" + "../common/event.rkt" + "../../lock.rkt") + +(provide + (protect-out slider%)) + +;; ---------------------------------------- + +(define-gtk gtk_hscale_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_vscale_new (_fun _pointer -> _GtkWidget)) +(define-gtk gtk_range_set_range (_fun _GtkWidget _double* _double* -> _void)) +(define-gtk gtk_range_set_increments (_fun _GtkWidget _double* _double* -> _void)) +(define-gtk gtk_range_set_value (_fun _GtkWidget _double* -> _void)) +(define-gtk gtk_range_get_value (_fun _GtkWidget -> _double)) +(define-gtk gtk_scale_set_draw_value (_fun _GtkWidget _gboolean -> _void)) + +(define-signal-handler connect-changed "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx queue-changed))))) + +(defclass slider% item% + (init parent cb + label + val lo hi + x y w + style + font) + (inherit get-gtk set-auto-size) + + (super-new [parent parent] + [gtk (as-gtk-allocation + (if (memq 'vertical style) + (gtk_vscale_new #f) + (gtk_hscale_new #f)))] + [callback cb] + [no-show? (memq 'deleted style)]) + (define gtk (get-gtk)) + + (gtk_range_set_range gtk lo hi) + (gtk_range_set_increments gtk 1.0 1.0) + (gtk_range_set_value gtk val) + + (when (memq 'plain style) + (gtk_scale_set_draw_value gtk #f)) + + (set-auto-size) + + (connect-changed gtk) + + (define callback cb) + (define ignore-click? #f) + (define/public (queue-changed) + ;; Called in event-dispatch thread + (gtk_range_set_value gtk (floor (gtk_range_get_value gtk))) + (unless ignore-click? + (queue-window-event + this + (lambda () + (callback this (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)])))))) + + (define/public (set-value v) + (atomically + (set! ignore-click? #t) + (gtk_range_set_value gtk v) + (set! ignore-click? #f))) + (define/public (get-value) + (inexact->exact (floor (gtk_range_get_value gtk))))) diff --git a/collects/mred/private/wx/gtk/stddialog.rkt b/collects/mred/private/wx/gtk/stddialog.rkt new file mode 100644 index 00000000..f2a2dc78 --- /dev/null +++ b/collects/mred/private/wx/gtk/stddialog.rkt @@ -0,0 +1,55 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "types.rkt" + "utils.rkt" + "widget.rkt" + "queue.rkt" + "../common/queue.rkt") + +(provide + (protect-out show-dialog + _GtkResponse)) + +(define _GtkResponse + (_enum + '(none = -1 + reject = -2 + accept = -3 + delete-event = -4 + ok = -5 + cancel = -6 + close = -7 + yes = -8 + no = -9 + apply = -10 + help = -11) + _fixint)) + +(define-signal-handler connect-response "response" + (_fun _GtkWidget _GtkResponse _pointer -> _void) + (lambda (gtk id data) + (let* ([p (ptr-ref data _racket)] + [response-sema (car p)] + [response-box (cdr p)]) + (set-box! response-box id) + (semaphore-post response-sema)))) + +(define (show-dialog dlg-gtk + [validate? (lambda (val) #t)]) + (let* ([response-sema (make-semaphore)] + [response-box (box #f)] + [cell (malloc-immobile-cell (cons response-sema + response-box))] + [es (current-eventspace)]) + (connect-response dlg-gtk cell) + (eventspace-adjust-external-modal! es 1) + (gtk_widget_show dlg-gtk) + (let loop () + (yield response-sema) + (unless (validate? (unbox response-box)) + (loop))) + (eventspace-adjust-external-modal! es -1) + (free-immobile-cell cell) ;; FIXME : don't leak + (gtk_widget_hide dlg-gtk) + (unbox response-box))) diff --git a/collects/mred/private/wx/gtk/style.rkt b/collects/mred/private/wx/gtk/style.rkt new file mode 100644 index 00000000..4cc7f1e6 --- /dev/null +++ b/collects/mred/private/wx/gtk/style.rkt @@ -0,0 +1,90 @@ +#lang racket/base +(require ffi/unsafe + "types.rkt" + "utils.rkt" + "init.rkt") + +(provide + (protect-out get-selected-text-color + get-selected-background-color)) + +(define-cstruct _GTypeInstance + ([class _pointer])) + +(define-cstruct _GObject + ([g_type_instance _GTypeInstance] + [ref_count _uint] + [qdata _pointer])) + +(define-cstruct _GtkStyle + ([obj _GObject] + [fg1 _GdkColor] + [fg2 _GdkColor] + [fg3 _GdkColor] + [fg4 _GdkColor] + [fg5 _GdkColor] + [bg1 _GdkColor] + [bg2 _GdkColor] + [bg3 _GdkColor] + [bg4 _GdkColor] + [bg5 _GdkColor] + [light1 _GdkColor] + [light2 _GdkColor] + [light3 _GdkColor] + [light4 _GdkColor] + [light5 _GdkColor] + [dark1 _GdkColor] + [dark2 _GdkColor] + [dark3 _GdkColor] + [dark4 _GdkColor] + [dark5 _GdkColor] + [mid1 _GdkColor] + [mid2 _GdkColor] + [mid3 _GdkColor] + [mid4 _GdkColor] + [mid5 _GdkColor] + [text1 _GdkColor] + [text2 _GdkColor] + [text3 _GdkColor] + [text4 _GdkColor] + [text5 _GdkColor] + [base1 _GdkColor] + [base2 _GdkColor] + [base3 _GdkColor] + [base4 _GdkColor] + [base5 _GdkColor] + [text_aa1 _GdkColor] + [text_aa2 _GdkColor] + [text_aa3 _GdkColor] + [text_aa4 _GdkColor] + [text_aa5 _GdkColor] + [black _GdkColor] + [white _GdkColor] + [font_desc _pointer] ; PangoFontDescription * + ; ... + )) + +(define-gtk gtk_widget_get_style (_fun _GtkWidget -> _GtkStyle-pointer)) +(define-gtk gtk_rc_get_style (_fun _GtkWidget -> _GtkStyle-pointer)) +(define-gtk gtk_text_view_new (_fun -> _GtkWidget)) + +(define the-text-style + (let ([w (gtk_text_view_new)]) + (let ([style (gtk_rc_get_style w)]) + (g_object_ref style) + (begin0 + style + (g_object_ref_sink w) + (g_object_unref w))))) + +(define (extract-color-values c) + (define (s v) (arithmetic-shift v -8)) + (values (s (GdkColor-red c)) + (s (GdkColor-green c)) + (s (GdkColor-blue c)))) + +(define (get-selected-text-color) + (extract-color-values (GtkStyle-text4 the-text-style))) + +(define (get-selected-background-color) + (extract-color-values (GtkStyle-base4 the-text-style))) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt new file mode 100644 index 00000000..33dfaa0c --- /dev/null +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -0,0 +1,171 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "window.rkt" + "client-window.rkt" + "utils.rkt" + "panel.rkt" + "types.rkt" + "widget.rkt" + "message.rkt" + "../common/event.rkt") + +(provide + (protect-out tab-panel%)) + +(define-gtk gtk_notebook_new (_fun -> _GtkWidget)) +(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) + +(define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) +(define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_notebook_set_scrollable (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) +(define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) + +(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) + +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) + +(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_unref (_fun _GtkWidget -> _void)) + +(define-struct page (bin-gtk label-gtk)) + +(define-signal-handler connect-changed "switch-page" + (_fun _GtkWidget _pointer _int -> _void) + (lambda (gtk ignored i) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx page-changed i))))) + +(define tab-panel% + (class (client-size-mixin (panel-mixin window%)) + (init parent + x y w h + style + labels) + + (inherit set-size set-auto-size infer-client-delta get-gtk + reset-child-dcs get-height) + + (define gtk (gtk_notebook_new)) + ;; Reparented so that it's always in the current page's bin: + (define client-gtk (gtk_fixed_new)) + + (gtk_notebook_set_scrollable gtk #t) + + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [extra-gtks (list client-gtk)] + [no-show? (memq 'deleted style)]) + + ; Once without tabs to set client-width delta: + (infer-client-delta #t #f) + + (define empty-bin-gtk (gtk_hbox_new #f 0)) + (define current-bin-gtk #f) + + (define (select-bin bin-gtk) + (set! current-bin-gtk bin-gtk) + (gtk_box_pack_start bin-gtk client-gtk #t #t 0) + ;; re-parenting can change the underlying window dc: + (reset-child-dcs)) + + (define pages + (for/list ([lbl labels]) + (let ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new_with_mnemonic lbl)]) + (gtk_notebook_append_page gtk bin-gtk label-gtk) + (gtk_widget_show bin-gtk) + (make-page bin-gtk label-gtk)))) + + (define/private (install-empty-page) + (gtk_notebook_append_page gtk empty-bin-gtk #f) + (gtk_widget_show empty-bin-gtk)) + + (if (null? pages) + (begin + (select-bin empty-bin-gtk) + (install-empty-page)) + (begin + (select-bin (page-bin-gtk (car pages))))) + (gtk_widget_show client-gtk) + + (connect-key-and-mouse gtk) + + ; With tabs to set client-width delta: + (infer-client-delta #f #t) + + (set-auto-size) + + (define callback void) + (define/public (set-callback cb) (set! callback cb)) + (define/private (do-callback) + (callback this (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))) + + (define/public (swap-in bin-gtk) + (gtk_widget_ref client-gtk) + (gtk_container_remove current-bin-gtk client-gtk) + (select-bin bin-gtk) + (gtk_widget_unref client-gtk)) + + (define/public (page-changed i) + (unless (null? pages) + (swap-in (page-bin-gtk (list-ref pages i))) + (queue-window-event this (lambda () (do-callback))))) + (connect-changed gtk) + + (define/override (get-client-gtk) client-gtk) + + (public [append* append]) + (define (append* lbl) + (let ([page + (let ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new_with_mnemonic lbl)]) + (gtk_notebook_append_page gtk bin-gtk label-gtk) + (gtk_widget_show bin-gtk) + (make-page bin-gtk label-gtk))]) + (set! pages (append pages (list page))) + (when (null? (cdr pages)) + (swap-in (page-bin-gtk (car pages))) + (g_object_ref empty-bin-gtk) + (gtk_notebook_remove_page gtk 0)))) + + (define/public (delete i) + (let ([page (list-ref pages i)]) + (when (ptr-equal? current-bin-gtk (page-bin-gtk page)) + (let ([cnt (length pages)]) + (if (= i (sub1 cnt)) + (if (null? (cdr pages)) + (begin + (install-empty-page) + (set! pages null) + (gtk_notebook_set_current_page gtk 1) + (swap-in empty-bin-gtk)) + (gtk_notebook_set_current_page gtk (sub1 i))) + (gtk_notebook_set_current_page gtk (add1 i))))) + (gtk_notebook_remove_page gtk i) + (set! pages (remq page pages)))) + + (define/public (set choices) + (for ([page (in-list pages)]) + (delete 0)) + (for ([lbl (in-list choices)]) + (append* lbl))) + + (define/public (set-label i str) + (gtk_label_set_text_with_mnemonic (page-label-gtk (list-ref pages i)) + (mnemonic-string str))) + + (define/public (set-selection i) + (gtk_notebook_set_current_page gtk i)) + (define/public (get-selection) + (gtk_notebook_get_current_page gtk)) + + (define/override (set-child-size child-gtk x y w h) + (gtk_fixed_move client-gtk child-gtk x y) + (gtk_widget_set_size_request child-gtk w h)))) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt new file mode 100644 index 00000000..20bb567c --- /dev/null +++ b/collects/mred/private/wx/gtk/types.rkt @@ -0,0 +1,156 @@ +#lang racket/base +(require ffi/unsafe) + +(provide + (protect-out _GdkWindow + _GtkWidget _GtkWindow + _GdkDisplay + _GdkScreen + _gpointer + _GType + _GdkEventType + _GdkAtom + + _fnpointer + _gboolean + _gfloat + + _GdkEventButton _GdkEventButton-pointer + (struct-out GdkEventButton) + _GdkEventKey _GdkEventKey-pointer + (struct-out GdkEventKey) + _GdkEventScroll _GdkEventScroll-pointer + (struct-out GdkEventScroll) + _GdkEventMotion _GdkEventMotion-pointer + (struct-out GdkEventMotion) + _GdkEventCrossing _GdkEventCrossing-pointer + (struct-out GdkEventCrossing) + _GdkEventConfigure _GdkEventConfigure-pointer + (struct-out GdkEventConfigure) + _GdkEventExpose _GdkEventExpose-pointer + (struct-out GdkEventExpose) + _GdkEventSelection _GdkEventSelection-pointer + (struct-out GdkEventSelection) + (struct-out GdkRectangle) + _GdkColor _GdkColor-pointer + (struct-out GdkColor))) + +(define _GType _long) + +(define _GdkWindow (_cpointer/null 'GdkWindow)) + +(define _GtkWidget (_cpointer 'GtkWidget)) +(define _GtkWindow _GtkWidget) + +(define _GdkDisplay (_cpointer 'GdkDisplay)) +(define _GdkScreen (_cpointer 'GdkScreen)) + +(define _gpointer _GtkWidget) + +(define _GdkDevice (_cpointer 'GdkDevice)) + +(define _fnpointer _pointer) ; a function pointer that can be NULL +(define _gboolean _bool) +(define _gfloat _float) +(define _GdkEventType _int) + +(define _GdkAtom _intptr) + +(define-cstruct _GdkEventButton ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [axes _pointer] ; array of _double + [state _uint] + [button _uint] + [device _GdkDevice] + [x_root _double] + [y_root _double])) + + +(define-cstruct _GdkEventKey ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [state _uint] + [keyval _uint] + [length _int] + [string _pointer] ; do not use + [hardware_keycode _uint16] + [group _ubyte] + [is_modifier _byte])) ; just 1 bit + +(define-cstruct _GdkEventScroll ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [state _uint] + [direction _uint] + [device _GdkDevice] + [x_root _double] + [y_root _double])) + +(define-cstruct _GdkEventMotion ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [time _uint32] + [x _double] + [y _double] + [axes _pointer] + [state _uint] + [is_hint _int16] + [device _GdkDevice] + [x_root _double] + [y_root _double])) + +(define-cstruct _GdkEventCrossing ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [subwindow _GdkWindow] + [time _uint32] + [x _double] + [y _double] + [x_root _double] + [y_root _double] + [mode _int] + [detail _int] + [focus _gboolean] + [state _uint])) + +(define-cstruct _GdkEventConfigure ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [x _int] + [y _int] + [width _int] + [height _int])) + +(define-cstruct _GdkEventSelection ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) + +(define-cstruct _GdkRectangle ([x _int] + [y _int] + [width _int] + [height _int])) + +(define-cstruct _GdkEventExpose ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [area _GdkRectangle] + [region _pointer] + [count _int])) + +(define-cstruct _GdkColor ([pixel _uint32] + [red _uint16] + [green _uint16] + [blue _uint16])) diff --git a/collects/mred/private/wx/gtk/unique.rkt b/collects/mred/private/wx/gtk/unique.rkt new file mode 100644 index 00000000..5385a725 --- /dev/null +++ b/collects/mred/private/wx/gtk/unique.rkt @@ -0,0 +1,98 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + racket/draw/unsafe/bstr + net/base64 + "../common/queue.rkt" + "types.rkt" + "utils.rkt") + +(provide + (protect-out do-single-instance)) + +(define unique-lib + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (ffi-lib "libunique-1.0" '("0")))) + +(define-ffi-definer define-unique unique-lib + #:default-make-fail make-not-available) + +(define _gsize _ulong) + +(define UNIQUE_RESPONSE_OK 1) + +(define _UniqueApp _GtkWidget) ; not a widget, but we want to connect a signal +(define _UniqueMessageData (_cpointer 'UniqueMessageData)) + +(define-unique unique_app_new (_fun _string _string -> _UniqueApp) + #:fail (lambda () (lambda args #f))) +(define-unique unique_app_add_command (_fun _UniqueApp _string _int -> _void)) +(define-unique unique_app_is_running (_fun _UniqueApp -> _gboolean)) +(define-unique unique_app_send_message (_fun _UniqueApp _int _UniqueMessageData -> _int)) + +(define-unique unique_message_data_new (_fun -> _UniqueMessageData)) +(define-unique unique_message_data_free (_fun _UniqueMessageData -> _void)) +(define-unique unique_message_data_set (_fun _UniqueMessageData _pointer _gsize -> _void)) +(define-unique unique_message_data_get (_fun _UniqueMessageData (len : (_ptr o _gsize)) + -> (data : _bytes) + -> (scheme_make_sized_byte_string + data + len + 0))) + +(define-signal-handler connect-message-received "message-received" + (_fun _UniqueApp _int _UniqueMessageData _uint -> _int) + (lambda (app cmd data time) + (let ([d (unique_message_data_get data)]) + (with-handlers ([exn:fail? (lambda (exn) + (log-error + (format "error handling single-instance message: ~s" + (exn-message exn))))]) + (let* ([p (open-input-bytes d)] + [vec (read p)]) + (for-each + queue-file-event + (map string->path (vector->list vec)))))) + UNIQUE_RESPONSE_OK)) + +(define-mz gethostname (_fun _pointer _long -> _int) + #:fail (lambda () #f)) + +(define HOSTLEN 256) + +(define (build-app-name) + (let-values ([(path) (simplify-path + (path->complete-path + (or (find-executable-path (find-system-path 'run-file) #f) + (find-system-path 'run-file)) + (current-directory)))] + [(host) (or (and gethostname + (let ([b (make-bytes HOSTLEN)]) + (and (zero? (gethostname b HOSTLEN)) + (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" b)) #\?)))) + "")]) + (string->bytes/utf-8 + (format "org.racket-lang.~a" + (encode + (format "~a~a~a" host path (version))))))) + +(define (encode s) + (regexp-replace* #rx"=|\r\n" (base64-encode (string->bytes/utf-8 s)) "")) + +(define (send-command-line app) + (let ([msg (unique_message_data_new)] + [b (let ([o (open-output-bytes)]) + (write (current-command-line-arguments) o) + (get-output-bytes o))]) + (unique_message_data_set msg b (bytes-length b)) + (unique_app_send_message app 42 msg))) + +(define (do-single-instance) + (let ([app (unique_app_new (build-app-name) #f)]) + (when app + (unique_app_add_command app "startup" 42) + (when (unique_app_is_running app) + (when (= (send-command-line app) + UNIQUE_RESPONSE_OK) + (exit 0))) + (void (connect-message-received app))))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt new file mode 100644 index 00000000..069e4d42 --- /dev/null +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -0,0 +1,184 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + racket/draw/unsafe/glib + (only-in '#%foreign ctype-c->scheme) + "../common/utils.rkt" + "types.rkt") + +(provide + define-mz + define-gobj + define-glib + (protect-out define-gtk + define-gdk + define-gdk_pixbuf + + g_object_ref + g_object_ref_sink + g_object_unref + + gobject-ref + gobject-unref + as-gobject-allocation + + as-gtk-allocation + as-gtk-window-allocation + clean-up-destroyed + + g_free + _gpath/free + _GSList + gfree + + g_object_set_data + g_object_get_data + + g_object_new + + (rename-out [g_object_get g_object_get_window]) + + get-gtk-object-flags + set-gtk-object-flags! + + define-signal-handler + + gdk_screen_get_default + + ;; for declaring derived structures: + _GtkObject)) + +(define gdk-lib + (case (system-type) + [(windows) + (ffi-lib "libatk-1.0-0") + (ffi-lib "libgio-2.0-0") + (ffi-lib "libgdk_pixbuf-2.0-0") + (ffi-lib "libgdk-win32-2.0-0")] + [else (ffi-lib "libgdk-x11-2.0" '("0"))])) +(define gdk_pixbuf-lib + (case (system-type) + [(windows) + (ffi-lib "libgdk_pixbuf-2.0-0")] + [(unix) + (ffi-lib "libgdk_pixbuf-2.0" '("0"))] + [else gdk-lib])) +(define gtk-lib + (case (system-type) + [(windows) + (ffi-lib "libgtk-win32-2.0-0")] + [else (ffi-lib "libgtk-x11-2.0" '("0"))])) + +(define-ffi-definer define-gtk gtk-lib) +(define-ffi-definer define-gdk gdk-lib) +(define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) + +(define-gobj g_object_ref (_fun _pointer -> _pointer)) +(define-gobj g_object_unref (_fun _pointer -> _void)) +(define-gobj g_object_ref_sink (_fun _pointer -> _pointer)) + +(define gobject-unref ((deallocator) g_object_unref)) +(define gobject-ref ((allocator gobject-unref) g_object_ref)) + +(define-syntax-rule (as-gobject-allocation expr) + ((gobject-allocator (lambda () expr)))) + +(define gobject-allocator (allocator gobject-unref)) + +(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void)) + +(define gtk-destroy ((deallocator) (lambda (v) + (gtk_widget_destroy v) + (g_object_unref v)))) + +(define gtk-allocator (allocator remember-to-free-later)) +(define (clean-up-destroyed) + (free-remembered-now gtk-destroy)) + +(define-syntax-rule (as-gtk-allocation expr) + ((gtk-allocator (lambda () (let ([v expr]) + (g_object_ref_sink v) + v))))) +(define-syntax-rule (as-gtk-window-allocation expr) + ((gtk-allocator (lambda () (let ([v expr]) + (g_object_ref v) + v))))) + +(define-glib g_free (_fun _pointer -> _void)) +(define gfree ((deallocator) g_free)) + +(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) +(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) + +(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong)) +(define (g_signal_connect obj s proc user-data) + (g_signal_connect_data obj s proc user-data #f 0)) + +(define-gobj g_object_get (_fun _GtkWidget (_string = "window") + [w : (_ptr o _GdkWindow)] + (_pointer = #f) -> _void -> w)) + +(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget)) + +;; This seems dangerous, since the shape of GtkObject is not +;; documented. But it seems to be the only way to get and set +;; flags. +(define-cstruct _GtkObject ([type-instance _pointer] + [ref_count _uint] + [qdata _pointer] + [flags _uint32])) +(define (get-gtk-object-flags gtk) + (GtkObject-flags (cast gtk _pointer _GtkObject-pointer))) +(define (set-gtk-object-flags! gtk v) + (set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v)) + +(define-gmodule g_module_open (_fun _path _int -> _pointer)) + +(define-syntax-rule (define-signal-handler + connect-name + signal-name + (_fun . args) + proc) + (begin + (define handler-proc proc) + (define handler_function + (function-ptr handler-proc (_fun #:atomic? #t . args))) + (define (connect-name gtk [user-data #f]) + (g_signal_connect gtk signal-name handler_function user-data)))) + + +(define _gpath/free + (make-ctype _pointer + path->bytes ; a Racket bytes can be used as a pointer + (lambda (x) + (let ([b (bytes->path (make-byte-string x))]) + (g_free x) + b)))) + +(define-cstruct _g-slist + ([data _pointer] + [next (_or-null _g-slist-pointer)])) + +(define-glib g_slist_free (_fun _g-slist-pointer -> _void)) +;; This should probably be provided by Racket +(define make-byte-string + (get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket))) + +(define (_GSList elem) + (make-ctype (_or-null _g-slist-pointer) + (lambda (l) + (let L ([l l]) + (if (null? l) + #f + (make-g-slist (car l) (L (cdr l)))))) + (lambda (gl) + (begin0 + (let L ([gl gl]) + (if (not gl) + null + (cons ((ctype-c->scheme elem) (g-slist-data gl)) + (L (g-slist-next gl))))) + (g_slist_free gl))))) + +(define-gdk gdk_screen_get_default (_fun -> _GdkScreen)) diff --git a/collects/mred/private/wx/gtk/w32.rkt b/collects/mred/private/wx/gtk/w32.rkt new file mode 100644 index 00000000..8e995ba6 --- /dev/null +++ b/collects/mred/private/wx/gtk/w32.rkt @@ -0,0 +1,32 @@ +#lang racket/base + +(provide QS_ALLINPUT) + +(define QS_KEY #x0001) +(define QS_MOUSEMOVE #x0002) +(define QS_MOUSEBUTTON #x0004) +(define QS_POSTMESSAGE #x0008) +(define QS_TIMER #x0010) +(define QS_PAINT #x0020) +(define QS_SENDMESSAGE #x0040) +(define QS_HOTKEY #x0080) +(define QS_ALLPOSTMESSAGE #x0100) +(define QS_RAWINPUT #x0400) +(define QS_MOUSE (bitwise-ior QS_MOUSEMOVE + QS_MOUSEBUTTON)) + +(define QS_INPUT (bitwise-ior QS_MOUSE + QS_KEY + QS_RAWINPUT)) +(define QS_ALLEVENTS (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY)) + +(define QS_ALLINPUT (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY + QS_SENDMESSAGE)) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt new file mode 100644 index 00000000..ed9e5327 --- /dev/null +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -0,0 +1,79 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "queue.rkt" + "utils.rkt" + "types.rkt") + +(provide + (protect-out widget% + gtk->wx + + gtk_widget_show + gtk_widget_hide + gtk_widget_destroy + + gtk_vbox_new + gtk_hbox_new + gtk_box_pack_start + gtk_box_pack_end)) + +(define-gtk gtk_widget_show (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) + +(define-gtk gtk_widget_destroy (_fun _pointer -> _void)) + +(define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) +(define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) +(define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) +(define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) + +(define-signal-handler connect-destroy "destroy" + (_fun _GtkWidget _pointer -> _void) + (lambda (gtk cell) + (free-immobile-cell cell))) + +(define widget% + (class object% + (init gtk + [extra-gtks null] + [parent #f]) + (init-field [eventspace (if parent + (send parent get-eventspace) + (current-eventspace))]) + + (when (eventspace-shutdown? eventspace) + (error '|GUI object initialization| "the eventspace has been shutdown")) + + (define/public (get-eventspace) eventspace) + (define/public (direct-update?) #t) + + (define/public (install-widget-parent p) + (set! eventspace (send p get-eventspace))) + + (super-new) + + (atomically + (let ([cell (malloc-immobile-cell (make-weak-box this))]) + (g_object_set_data gtk "wx" cell) + (for ([gtk (in-list extra-gtks)]) + (g_object_set_data gtk "wx" cell)) + (connect-destroy gtk cell))))) + +(define (gtk->wx gtk) + (let ([ptr (g_object_get_data gtk "wx")]) + (and ptr + (let ([wb (ptr-ref ptr _scheme)]) + (and wb (weak-box-value wb)))))) + +(set-widget-hook! (lambda (gtk) + (let loop ([gtk gtk]) + (and gtk + (let ([wx (gtk->wx gtk)]) + (or wx + (loop (gtk_widget_get_parent gtk)))))))) + diff --git a/collects/mred/private/wx/gtk/win32.rkt b/collects/mred/private/wx/gtk/win32.rkt new file mode 100644 index 00000000..a7414899 --- /dev/null +++ b/collects/mred/private/wx/gtk/win32.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + "utils.rkt") + +(provide gdk_win32_drawable_get_handle + GetDC + ReleaseDC) + +(define user32-lib + (cond + [(eq? 'windows (system-type)) + (ffi-lib "user32.dll")] + [else #f])) + +(define-ffi-definer define-user32 user32-lib) + +(define _GdkDrawable _pointer) + +(define-gdk gdk_win32_drawable_get_handle (_fun _GdkDrawable -> _pointer) + #:make-fail make-not-available) + +(define-user32 GetDC (_fun #:abi 'stdcall _pointer -> _pointer) + #:make-fail make-not-available) +(define-user32 ReleaseDC (_fun #:abi 'stdcall _pointer -> _void) + #:make-fail make-not-available) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt new file mode 100644 index 00000000..e4cc352e --- /dev/null +++ b/collects/mred/private/wx/gtk/window.rkt @@ -0,0 +1,683 @@ +#lang racket/base +(require ffi/unsafe + racket/class + ffi/unsafe/atomic + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" + "../common/local.rkt" + "../common/delay.rkt" + racket/draw/unsafe/bstr + "keycode.rkt" + "keymap.rkt" + "queue.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "widget.rkt" + "clipboard.rkt") + +(provide + (protect-out window% + queue-window-event + queue-window-refresh-event + + gtk_widget_realize + gtk_container_add + gtk_widget_add_events + gtk_widget_size_request + gtk_widget_set_size_request + gtk_widget_grab_focus + gtk_widget_set_sensitive + + connect-focus + connect-key-and-mouse + do-button-event + + (struct-out GtkRequisition) _GtkRequisition-pointer + (struct-out GtkAllocation) _GtkAllocation-pointer + + widget-window + + the-accelerator-group + gtk_window_add_accel_group + gtk_menu_set_accel_group + + flush-display + gdk_display_get_default + + request-flush-delay + cancel-flush-delay) + gtk->wx + gtk_widget_show + gtk_widget_hide) + +;; ---------------------------------------- + +(define-gtk gtk_container_add (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_widget_realize (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_add_events (_fun _GtkWidget _int -> _void)) + +(define-gdk gdk_keyval_to_unicode (_fun _uint -> _uint32)) + +(define-cstruct _GtkRequisition ([width _int] + [height _int])) +(define-cstruct _GtkAllocation ([x _int] + [y _int] + [width _int] + [height _int])) + +(define _GdkEventFocus-pointer _pointer) + +(define-gtk gtk_widget_size_request (_fun _GtkWidget _GtkRequisition-pointer -> _void)) +(define-gtk gtk_widget_size_allocate (_fun _GtkWidget _GtkAllocation-pointer -> _void)) +(define-gtk gtk_widget_set_size_request (_fun _GtkWidget _int _int -> _void)) +(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void)) + +(define _GtkAccelGroup (_cpointer 'GtkAccelGroup)) +(define-gtk gtk_accel_group_new (_fun -> _GtkAccelGroup)) +(define-gtk gtk_window_add_accel_group (_fun _GtkWindow _GtkAccelGroup -> _void)) +(define-gtk gtk_menu_set_accel_group (_fun _GtkWidget _GtkAccelGroup -> _void)) + +(define the-accelerator-group (gtk_accel_group_new)) + +(define-cstruct _GtkWidgetT ([obj _GtkObject] + [private_flags _uint16] + [state _byte] + [saved_state _byte] + [name _pointer] + [style _pointer] + [req _GtkRequisition] + [alloc _GtkAllocation] + [window _GdkWindow] + [parent _GtkWidget])) + +(define (widget-window gtk) + (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) + +(define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void)) +(define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void)) +(define-gtk gtk_drag_dest_unset (_fun _GtkWidget -> _void)) + +(define GTK_DEST_DEFAULT_ALL #x07) +(define GDK_ACTION_COPY (arithmetic-shift 1 1)) + +(define-signal-handler connect-drag-data-received "drag-data-received" + (_fun _GtkWidget _pointer _int _int _GtkSelectionData _uint _uint -> _void) + (lambda (gtk context x y data info time) + (let ([wx (gtk->wx gtk)]) + (when wx + (let ([bstr (scheme_make_sized_byte_string + (gtk_selection_data_get_data data) + (gtk_selection_data_get_length data) + 1)]) + (cond + [(regexp-match #rx#"^file://(.*)\r\n$" bstr) + => (lambda (m) + (queue-window-event wx + (lambda () + (let ([path (bytes->path (cadr m))]) + (send wx on-drop-file path)))))])))))) + +;; ---------------------------------------- + +(define-signal-handler connect-focus-in "focus-in-event" + (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (when wx + (send (send wx get-top-win) on-focus-child #t) + (queue-window-event wx (lambda () (send wx on-set-focus)))) + #f))) +(define-signal-handler connect-focus-out "focus-out-event" + (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (when wx + (send (send wx get-top-win) on-focus-child #f) + (queue-window-event wx (lambda () (send wx on-kill-focus)))) + #f))) +(define (connect-focus gtk) + (connect-focus-in gtk) + (connect-focus-out gtk)) + +(define-signal-handler connect-size-allocate "size-allocate" + (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) + (lambda (gtk a) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx save-size + (GtkAllocation-x a) + (GtkAllocation-y a) + (GtkAllocation-width a) + (GtkAllocation-height a)))) + #t)) +;; ---------------------------------------- + +(define-signal-handler connect-key-press "key-press-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (do-key-event gtk event #t #f))) + +(define-signal-handler connect-key-release "key-release-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (do-key-event gtk event #f #f))) + +(define-signal-handler connect-scroll "scroll-event" + (_fun _GtkWidget _GdkEventScroll-pointer -> _gboolean) + (lambda (gtk event) + (and (member (GdkEventScroll-direction event) + (list GDK_SCROLL_UP + GDK_SCROLL_DOWN)) + (do-key-event gtk event #f #t)))) + +(define (do-key-event gtk event down? scroll?) + (let ([wx (gtk->wx gtk)]) + (and + wx + (let* ([modifiers (if scroll? + (GdkEventScroll-state event) + (GdkEventKey-state event))] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [keyval->code (lambda (kv) + (or + (map-key-code kv) + (integer->char (gdk_keyval_to_unicode kv))))] + [key-code (if scroll? + (if (= (GdkEventScroll-direction event) + GDK_SCROLL_UP) + 'wheel-up + 'wheel-down) + (keyval->code (GdkEventKey-keyval event)))] + [k (new key-event% + [key-code key-code] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_MOD1_MASK)] + [alt-down (bit? modifiers GDK_META_MASK)] + [x 0] + [y 0] + [time-stamp (if scroll? + (GdkEventScroll-time event) + (GdkEventKey-time event))] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (when (or (and (not scroll?) + (let-values ([(s ag sag cl) (get-alts event)] + [(keyval->code*) (lambda (v) + (and v + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 c)) + c))))]) + (let ([s (keyval->code* s)] + [ag (keyval->code* ag)] + [sag (keyval->code* sag)] + [cl (keyval->code* cl)]) + (when s (send k set-other-shift-key-code s)) + (when ag (send k set-other-altgr-key-code ag)) + (when sag (send k set-other-shift-altgr-key-code sag)) + (when cl (send k set-other-caps-key-code cl)) + (or s ag sag cl)))) + (not (equal? #\u0000 key-code))) + (unless (or scroll? down?) + ;; swap altenate with main + (send k set-key-release-code (send k get-key-code)) + (send k set-key-code 'release)) + (if (send wx handles-events? gtk) + (begin + (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t))))))) + +(define-signal-handler connect-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (unless (gtk_widget_is_focus gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (unless (other-modal? wx) + (gtk_widget_grab_focus gtk))))) + (do-button-event gtk event #f #f))) + +(define-signal-handler connect-button-release "button-release-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (do-button-event gtk event #f #f))) + +(define-signal-handler connect-pointer-motion "motion-notify-event" + (_fun _GtkWidget _GdkEventMotion-pointer -> _gboolean) + (lambda (gtk event) + (do-button-event gtk event #t #f))) + +(define-signal-handler connect-enter "enter-notify-event" + (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) (when wx (send wx enter-window))) + (do-button-event gtk event #f #t))) + +(define-signal-handler connect-leave "leave-notify-event" + (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window))) + (do-button-event gtk event #f #t))) + +(define (connect-key-and-mouse gtk [skip-press? #f]) + (connect-key-press gtk) + (connect-key-release gtk) + (connect-scroll gtk) + (connect-button-press gtk) + (unless skip-press? (connect-button-release gtk)) + (connect-pointer-motion gtk) + (connect-enter gtk) + (connect-leave gtk)) + +(define (do-button-event gtk event motion? crossing?) + (let ([type (if motion? + GDK_MOTION_NOTIFY + (if crossing? + (GdkEventCrossing-type event) + (GdkEventButton-type event)))]) + (unless (or (= type GDK_2BUTTON_PRESS) + (= type GDK_3BUTTON_PRESS)) + (let ([wx (gtk->wx gtk)]) + (and + wx + (let* ([modifiers (if motion? + (GdkEventMotion-state event) + (if crossing? + (GdkEventCrossing-state event) + (GdkEventButton-state event)))] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [type (cond + [(= type GDK_MOTION_NOTIFY) + 'motion] + [(= type GDK_ENTER_NOTIFY) + 'enter] + [(= type GDK_LEAVE_NOTIFY) + 'leave] + [(= type GDK_BUTTON_PRESS) + (case (GdkEventButton-button event) + [(1) 'left-down] + [(3) 'right-down] + [else 'middle-down])] + [else + (case (GdkEventButton-button event) + [(1) 'left-up] + [(3) 'right-up] + [else 'middle-up])])] + [m (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? modifiers GDK_BUTTON1_MASK)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? modifiers GDK_BUTTON2_MASK)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? modifiers GDK_BUTTON3_MASK)])] + [x (->long ((if motion? + GdkEventMotion-x + (if crossing? GdkEventCrossing-x GdkEventButton-x)) + event))] + [y (->long ((if motion? GdkEventMotion-y + (if crossing? GdkEventCrossing-y GdkEventButton-y)) + event))] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_META_MASK)] + [alt-down (bit? modifiers GDK_MOD1_MASK)] + [time-stamp ((if motion? GdkEventMotion-time + (if crossing? GdkEventCrossing-time GdkEventButton-time)) + event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (if (send wx handles-events? gtk) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (or (send wx dispatch-on-event m #t) + (send wx internal-pre-on-event gtk m))) + #t)))))))) + +;; ---------------------------------------- + +(define (internal-error str) + (log-error + (apply string-append + (format "internal error: ~a" str) + (append + (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) + (let ([name (car c)] + [loc (cdr c)]) + (cond + [loc + (string-append + "\n" + (cond + [(srcloc-line loc) + (format "~a:~a:~a" + (srcloc-source loc) + (srcloc-line loc) + (srcloc-column loc))] + [else + (format "~a::~a" + (srcloc-source loc) + (srcloc-position loc))]) + (if name (format " ~a" name) ""))] + [else (format "\n ~a" name)]))) + '("\n"))))) + +(define window% + (class widget% + (init-field parent + gtk) + (init [no-show? #f] + [extra-gtks null] + [add-to-parent? #t]) + + (super-new [gtk gtk] + [extra-gtks extra-gtks] + [parent parent]) + + (define save-x (get-unset-pos)) + (define save-y (get-unset-pos)) + (define save-w 0) + (define save-h 0) + + (define/public (get-unset-pos) 0) + + (connect-size-allocate gtk) + + (when add-to-parent? + (gtk_container_add (send parent get-client-gtk) gtk)) + + (define/public (get-gtk) gtk) + (define/public (get-client-gtk) gtk) + (define/public (get-window-gtk) (send parent get-window-gtk)) + + (define/public (move x y) + (set-size x y -1 -1)) + + (define/public (set-size x y w h) + (unless (and (or (= x -11111) (= save-x x)) + (or (= y -11111) (= save-y y)) + (or (= w -1) (= save-w w)) + (or (= h -1) (= save-h h))) + (unless (= x -11111) (set! save-x x)) + (unless (= y -11111) (set! save-y y)) + (unless (= w -1) (set! save-w w)) + (unless (= h -1) (set! save-h h)) + (set! save-w (max save-w client-delta-w)) + (set! save-h (max save-h client-delta-h)) + (really-set-size gtk x y save-x save-y save-w save-h))) + + (define/public (save-size x y w h) + (set! save-w w) + (set! save-h h)) + + (define/public (really-set-size gtk given-x given-y x y w h) + (send parent set-child-size gtk x y w h)) + + (define/public (set-child-size child-gtk x y w h) + (gtk_widget_set_size_request child-gtk w h) + (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) + + (define/public (remember-size w h) + ;; called in event-pump thread + (unless (and (= save-w w) + (= save-h h)) + (set! save-w w) + (set! save-h h) + (queue-on-size))) + + (define on-size-queued? #f) + (define/public (queue-on-size) + (unless on-size-queued? + (set! on-size-queued? #t) + (queue-window-event this (lambda () + (set! on-size-queued? #f) + (on-size 0 0))))) + + (define client-delta-w 0) + (define client-delta-h 0) + + (define/public (adjust-client-delta dw dh) + (set! client-delta-w dw) + (set! client-delta-h dh)) + + (define/public (infer-client-delta [w? #t] [h? #t] [sub-h-gtk #f]) + (let ([req (make-GtkRequisition 0 0)] + [creq (make-GtkRequisition 0 0)] + [hreq (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (gtk_widget_size_request (get-client-gtk) creq) + (when sub-h-gtk + (gtk_widget_size_request sub-h-gtk hreq)) + (when w? + (set! client-delta-w (- (GtkRequisition-width req) + (max (GtkRequisition-width creq) + (GtkRequisition-width hreq))))) + (when h? + (set! client-delta-h (- (GtkRequisition-height req) + (GtkRequisition-height creq)))))) + + (define/public (set-auto-size) + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request gtk req) + (set-size -11111 + -11111 + (GtkRequisition-width req) + (GtkRequisition-height req)))) + + (define shown? #f) + (define/public (direct-show on?) + ;; atomic mode + (if on? + (gtk_widget_show gtk) + (gtk_widget_hide gtk)) + (set! shown? (and on? #t)) + (register-child-in-parent on?) + (when on? (reset-child-dcs))) + (define/public (show on?) + (atomically + (direct-show on?))) + (define/public (reset-child-dcs) (void)) + (define/public (is-shown?) shown?) + (define/public (is-shown-to-root?) + (and shown? + (if parent + (send parent is-shown-to-root?) + #t))) + + (unless no-show? (show #t)) + + (define/public (get-x) (if (= save-x -11111) 0 save-x)) + (define/public (get-y) (if (= save-y -11111) 0 save-y)) + (define/public (get-width) save-w) + (define/public (get-height) save-h) + + (define/public (get-parent) parent) + + (define/public (get-top-win) (send parent get-top-win)) + + (define/public (get-dialog-level) (send parent get-dialog-level)) + + (define/public (get-size xb yb) + (set-box! xb save-w) + (set-box! yb save-h)) + (define/public (get-client-size xb yb) + (get-size xb yb) + (set-box! xb (max 0 (- (unbox xb) client-delta-w))) + (set-box! yb (max 0 (- (unbox yb) client-delta-h)))) + + (define enabled? #t) + (define/pubment (is-enabled-to-root?) + (and enabled? + (inner (send parent is-enabled-to-root?) + is-enabled-to-root?))) + (define/public (enable on?) + (set! enabled? on?) + (gtk_widget_set_sensitive gtk on?)) + (define/public (is-window-enabled?) enabled?) + + (define drag-connected? #f) + (define/public (drag-accept-files on?) + (if on? + (begin + (unless drag-connected? + (connect-drag-data-received gtk) + (set! drag-connected? #t)) + (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) + (gtk_drag_dest_add_uri_targets gtk)) + (gtk_drag_dest_unset gtk))) + + (define/public (set-focus) + (gtk_widget_grab_focus (get-client-gtk))) + + (define cursor-handle #f) + (define/public (set-cursor v) + (set! cursor-handle (and v + (send (send v get-driver) get-handle))) + (check-window-cursor this)) + (define/public (enter-window) + (set-window-cursor this #f)) + (define/public (leave-window) + (when parent + (send parent enter-window))) + (define/public (set-window-cursor in-win c) + (set-parent-window-cursor in-win (or c cursor-handle))) + (define/public (set-parent-window-cursor in-win c) + (when parent + (send parent set-window-cursor in-win c))) + (define/public (check-window-cursor win) + (when parent + (send parent check-window-cursor win))) + + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + + (define/private (pre-event-refresh) + ;; Since we break the connection between the + ;; Gtk queue and event handling, we + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corresponding + ;; stream of screen updates. + (flush-display)) + + (define/public (handles-events? gtk) #f) + (define/public (dispatch-on-char e just-pre?) + (pre-event-refresh) + (cond + [(other-modal? this) #t] + [(call-pre-on-char this e) #t] + [just-pre? #f] + [else (when enabled? (on-char e)) #t])) + (define/public (dispatch-on-event e just-pre?) + (pre-event-refresh) + (cond + [(other-modal? this) #t] + [(call-pre-on-event this e) #t] + [just-pre? #f] + [else (when enabled? (on-event e)) #t])) + + (define/public (internal-pre-on-event gtk e) #f) + + (define/public (call-pre-on-event w e) + (or (send parent call-pre-on-event w e) + (pre-on-event w e))) + (define/public (call-pre-on-char w e) + (or (send parent call-pre-on-char w e) + (pre-on-char w e))) + (define/public (pre-on-event w e) #f) + (define/public (pre-on-char w e) #f) + + (define/public (on-char e) (void)) + (define/public (on-event e) (void)) + + (define/public (on-size w h) (void)) + + (define/public (register-child child on?) + (void)) + (define/public (register-child-in-parent on?) + (when parent + (send parent register-child this on?))) + + (define/public (paint-children) + (void)) + + (define/public (on-drop-file path) (void)) + + (define/public (get-handle) (get-gtk)) + + (define/public (popup-menu m x y) + (let ([gx (box x)] + [gy (box y)]) + (client-to-screen gx gy) + (send m popup (unbox gx) (unbox gy) + (lambda (thunk) (queue-window-event this thunk))))) + + (define/public (center a b) (void)) + (define/public (refresh) (void)) + + (define/public (screen-to-client x y) + (let ([xb (box 0)] + [yb (box 0)]) + (client-to-screen xb yb) + (set-box! x (- (unbox x) (unbox xb))) + (set-box! y (- (unbox y) (unbox yb))))) + (define/public (client-to-screen x y) + (let-values ([(dx dy) (get-client-delta)]) + (send parent client-to-screen x y) + (set-box! x (+ (unbox x) save-x dx)) + (set-box! y (+ (unbox y) save-y dy)))) + + (define/public (get-client-delta) + (values 0 0)) + + (define/public (gets-focus?) #t))) + +(define (queue-window-event win thunk) + (queue-event (send win get-eventspace) thunk)) +(define (queue-window-refresh-event win thunk) + (queue-refresh-event (send win get-eventspace) thunk)) + +(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) +(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) +(define (flush-display) + (try-to-sync-refresh) + (gdk_window_process_all_updates) + (gdk_display_flush (gdk_display_get_default))) + +(define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void)) +(define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void)) +(define-gdk gdk_window_invalidate_rect (_fun _GdkWindow _pointer _gboolean -> _void)) +(define-gdk gdk_window_process_all_updates (_fun -> _void)) + +(define (request-flush-delay gtk) + (do-request-flush-delay + gtk + (lambda (gtk) + (let ([win (widget-window gtk)]) + (and win + (gdk_window_freeze_updates win) + #t))) + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk))))) + +(define (cancel-flush-delay req) + (when req + (do-cancel-flush-delay + req + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk)))))) diff --git a/collects/mred/private/wx/gtk/x11.rkt b/collects/mred/private/wx/gtk/x11.rkt new file mode 100644 index 00000000..cda9c15a --- /dev/null +++ b/collects/mred/private/wx/gtk/x11.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + "utils.rkt") + +(provide + (protect-out gdk_pixmap_new + gdk_drawable_get_display + gdk_drawable_get_visual + gdk_x11_drawable_get_xid + gdk_x11_display_get_xdisplay + gdk_x11_visual_get_xvisual)) + +(define _GdkDrawable _pointer) +(define _GdkDisplay (_cpointer 'GdkDisplay)) +(define _GdkVisual (_cpointer 'GdkVisual)) +(define _GdkPixmap (_cpointer 'GdkPixmap)) +(define _Visual (_cpointer 'Visual)) +(define _Display (_cpointer 'Display)) +(define _Drawable _ulong) + +(define-gdk gdk_pixmap_new (_fun _GdkDrawable _int _int _int -> _GdkPixmap) + #:wrap (allocator gobject-unref)) + +(define-gdk gdk_drawable_get_display (_fun _GdkDrawable -> _GdkDisplay)) +(define-gdk gdk_drawable_get_visual (_fun _GdkDrawable -> _GdkVisual)) + +(define-gdk gdk_x11_drawable_get_xid (_fun _GdkDrawable -> _Drawable) + #:make-fail make-not-available) + +(define-gdk gdk_x11_display_get_xdisplay (_fun _GdkDisplay -> _Display) + #:make-fail make-not-available) + +(define-gdk gdk_x11_visual_get_xvisual (_fun _GdkVisual -> _Visual) + #:make-fail make-not-available) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt new file mode 100644 index 00000000..79dcef79 --- /dev/null +++ b/collects/mred/private/wx/platform.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require racket/runtime-path + (for-syntax racket/base)) +(provide + (protect-out (all-defined-out))) + +(define-runtime-module-path-index platform-lib + (let ([gtk-lib + '(lib "mred/private/wx/gtk/platform.rkt")]) + (case (system-type) + [(windows) (if (getenv "PLT_WIN_GTK") + gtk-lib + '(lib "mred/private/wx/win32/platform.rkt"))] + [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")] + [(unix) gtk-lib]))) + +(define-values (button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + has-x-selection? + hide-cursor + bell + display-size + display-origin + flush-display + fill-private-color + cancel-quit + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + get-double-click-time + run-printout + file-creator-and-type + location->window + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + find-graphical-system-path + play-sound + get-panel-background + font-from-user-platform-mode + get-font-from-user + color-from-user-platform-mode + get-color-from-user + special-option-key + special-control-key + get-highlight-background-color + get-highlight-text-color + make-screen-bitmap + make-gl-bitmap + check-for-break) + ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt new file mode 100644 index 00000000..b492db36 --- /dev/null +++ b/collects/mred/private/wx/win32/button.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") + +(provide + (protect-out base-button% + button%)) + +(define BM_SETSTYLE #x00F4) + +(define base-button% + (class item% + (inherit set-control-font auto-size get-hwnd + remember-label-bitmap) + + (init parent cb label x y w h style font) + + (define callback cb) + + (define bitmap? + (and (label . is-a? . bitmap%) + (send label ok?))) + + (define/public (get-class) "PLTBUTTON") + (define/public (get-flags) BS_PUSHBUTTON) + + (super-new [callback cb] + [parent parent] + [hwnd + (CreateWindowExW/control 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + (when bitmap? + (let ([hbitmap (bitmap->hbitmap label #:bg (get-button-background))]) + (remember-label-bitmap hbitmap) + (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) + + (set-control-font font) + + (define/public (get-button-background) + #xFFFFFF) + + (define/public (auto-size-button font label) + (cond + [bitmap? + (auto-size font label 0 0 4 4)] + [else + (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) + (auto-size-button font label) + + (define/override (is-command? cmd) + (= cmd BN_CLICKED)) + + (define/public (do-command cmd control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'button] + [time-stamp (current-milliseconds)]))))) + + (define/public (set-border on?) + (SendMessageW (get-hwnd) BM_SETSTYLE + (if on? BS_DEFPUSHBUTTON BS_PUSHBUTTON) + 1)))) + +(define button% + (class base-button% + (super-new))) + + diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt new file mode 100644 index 00000000..92e3c78b --- /dev/null +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -0,0 +1,536 @@ +#lang racket/base +(require racket/class + ffi/unsafe + racket/draw + "../../syntax.rkt" + "../../lock.rkt" + "../common/canvas-mixin.rkt" + "../common/backing-dc.rkt" + "../common/event.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "window.rkt" + "dc.rkt" + "item.rkt" + "hbitmap.rkt" + "gcwin.rkt" + "theme.rkt") + +(provide + (protect-out canvas%)) + +(define WS_EX_STATICEDGE #x00020000) +(define WS_EX_CLIENTEDGE #x00000200) + +(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) +(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) +(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'ShowScrollbar)))) + +(define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) +(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) + -> (when (zero? r) (failed 'FillRect)))) + +(define _HRGN _pointer) +(define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) +(define DCX_WINDOW #x00000001) +(define DCX_CACHE #x00000002) + +(define EP_EDITTEXT 1) +(define ETS_NORMAL 1) +(define ETS_DISABLE 4) + +(define HTHSCROLL 6) +(define HTVSCROLL 7) + +(define-cstruct _SCROLLINFO + ([cbSize _UINT] + [fMask _UINT] + [nMin _int] + [nMax _int] + [nPage _UINT] + [nPos _int] + [nTrackPos _int])) + +(define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int)) +(define-user32 GetScrollPos (_wfun _HWND _int -> _int)) +(define-user32 SetScrollPos (_wfun _HWND _int _int _BOOL -> _int)) +(define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer + = (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) + (bitwise-ior SIF_RANGE SIF_POS + SIF_PAGE SIF_TRACKPOS) + 0 0 0 0 0)) + -> (r : _BOOL) + -> (if r i (error 'GetScrollInfo "failed")))) + +(define COMBO-WIDTH 18) + +(define canvas% + (canvas-mixin + (class (canvas-autoscroll-mixin (item-mixin window%)) + (init parent + x y w h + style + [ignored-name #f] + [gl-conf #f]) + + (inherit get-hwnd + get-client-size + get-eventspace + set-control-font + is-auto-scroll? get-virtual-width get-virtual-height + reset-auto-scroll + refresh-for-autoscroll + on-size) + + (define hscroll? (memq 'hscroll style)) + (define vscroll? (memq 'vscroll style)) + (define for-gl? (memq 'gl style)) + + (define panel-hwnd + (and (memq 'combo style) + (CreateWindowExW 0 + "PLTTabPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f))) + + (define canvas-hwnd + (CreateWindowExW (cond + [(memq 'border style) WS_EX_STATICEDGE] + [(memq 'control-border style) WS_EX_CLIENTEDGE] + [else 0]) + "PLTCanvas" + #f + (bitwise-ior WS_CHILD + (if panel-hwnd WS_VISIBLE 0) + (if hscroll? WS_HSCROLL 0) + (if vscroll? WS_VSCROLL 0)) + 0 0 w h + (or panel-hwnd (send parent get-hwnd)) + #f + hInstance + #f)) + (define combo-hwnd + (and panel-hwnd + (CreateWindowExW/control 0 + "PLTCOMBOBOX" + "" + (bitwise-ior WS_CHILD WS_VISIBLE + CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 w h + panel-hwnd + #f + hInstance + #f))) + + (define hwnd (or panel-hwnd canvas-hwnd)) + + (super-new [parent parent] + [hwnd hwnd] + [extra-hwnds (if panel-hwnd + (list canvas-hwnd combo-hwnd) + null)] + [style style]) + + (when combo-hwnd + (set-control-font #f combo-hwnd)) + + (define control-border-theme + (and (memq 'control-border style) + (OpenThemeData canvas-hwnd "Edit"))) + + (define/override (wndproc w msg wParam lParam default) + (cond + [(= msg WM_PAINT) + (let* ([ps (malloc 128)] + [hdc (BeginPaint w ps)]) + (when hdc + (if for-gl? + (queue-paint) + (if (positive? paint-suspended) + (set! suspended-refresh? #t) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) + (unless (do-canvas-backing-flush hdc) + (queue-paint))))) + (EndPaint hdc ps))) + 0] + [(= msg WM_NCPAINT) + (if control-border-theme + (let* ([r (GetWindowRect canvas-hwnd)] + [res (default w msg wParam lParam)] + [hdc (GetDCEx canvas-hwnd #f (bitwise-ior DCX_CACHE DCX_WINDOW))] + [wr (make-RECT 0 0 + (- (RECT-right r) (RECT-left r)) + (- (RECT-bottom r) (RECT-top r)))]) + (DrawThemeBackground control-border-theme + hdc + EP_EDITTEXT + ETS_NORMAL ;; or ETS_DISABLED? + wr + #f) + (ReleaseDC canvas-hwnd hdc) + 1) + (default w msg wParam lParam))] + [(= msg WM_HSCROLL) + (on-scroll-change SB_HORZ (LOWORD wParam)) + 0] + [(= msg WM_VSCROLL) + (on-scroll-change SB_VERT (LOWORD wParam)) + 0] + [else (super wndproc w msg wParam lParam default)])) + + (define/override (wndproc-for-ctlproc w msg wParam lParam default) + (default w msg wParam lParam)) + + (define dc (new dc% [canvas this])) + (send dc start-backing-retained) + + (define/public (get-dc) dc) + + (define gl-config gl-conf) + (define/public (get-gl-config) gl-config) + + (define/override (on-resized) + (reset-dc)) + + (define/private (reset-dc) + (send dc reset-backing-retained) + (send dc set-auto-scroll + (if (get-virtual-width) + (get-virtual-h-pos) + 0) + (if (get-virtual-height) + (get-virtual-v-pos) + 0))) + + (define/override (get-client-hwnd) + canvas-hwnd) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when panel-hwnd + (let* ([r (and (or (= w -1) (= h -1)) + (GetWindowRect hwnd))] + [w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)] + [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)]) + (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t) + (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t))) + (on-size 0 0)) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay this)) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (get-flush-window) canvas-hwnd) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + ;; Improve this method to flush locally + ;; instead of globally: + (define/public (flush) + (flush-display)) + + (define/public (on-paint) (void)) + (define/override (refresh) (queue-paint)) + + (define/public (queue-backing-flush) + (unless for-gl? + (InvalidateRect canvas-hwnd #f #f) + (schedule-periodic-backing-flush))) + + ;; overridden to extend for scheduled periodic flushes: + (define/public (schedule-periodic-backing-flush) + (void)) + (define/public (do-canvas-backing-flush hdc) + (if hdc + (do-backing-flush this dc hdc) + (if (positive? paint-suspended) + ;; suspended => try again later + (schedule-periodic-backing-flush) + ;; not suspended + (let ([hdc (GetDC canvas-hwnd)]) + (do-backing-flush this dc hdc) + (ReleaseDC canvas-hwnd hdc) + ;; We'd like to validate the region that + ;; we just updated, so we can potentially + ;; avoid a redundant refresh. For some reason, + ;; vadilation can cancel an update that hasn't + ;; happened, yet; this problem needs further + ;; invesitigation. + #; + (ValidateRect canvas-hwnd #f))))) + + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h)) + + (define paint-suspended 0) + (define suspended-refresh? #f) + (define/public (suspend-paint-handling) + (atomically + (set! paint-suspended (add1 paint-suspended)))) + (define/public (resume-paint-handling) + (atomically + (unless (zero? paint-suspended) + (set! paint-suspended (sub1 paint-suspended)) + (when (and (zero? paint-suspended) + suspended-refresh?) + (set! suspended-refresh? #f) + (InvalidateRect canvas-hwnd #f #f))))) + + (define no-autoclear? (memq 'no-autoclear style)) + (define transparent? (memq 'transparent style)) + (define bg-col (make-object color% "white")) + (define bg-colorref #xFFFFFF) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) + (define/public (get-canvas-background-for-backing) (and (not transparent?) + (not no-autoclear?) + bg-col)) + (define/public (set-canvas-background col) + (atomically + (set! bg-col col) + (set! bg-colorref (make-COLORREF (send col red) + (send col green) + (send col blue))))) + + (define wants-focus? (not (memq 'no-focus style))) + (define/override (can-accept-focus?) + wants-focus?) + + (define h-scroll-visible? hscroll?) + (define v-scroll-visible? vscroll?) + (define/public (show-scrollbars h? v?) + (when hscroll? + (atomically + (set! h-scroll-visible? (and h? #t)) + (ShowScrollBar canvas-hwnd SB_HORZ h?))) + (when vscroll? + (atomically + (set! v-scroll-visible? (and v? #t)) + (ShowScrollBar canvas-hwnd SB_VERT v?)))) + + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) + (define (make-info len page pos vis?) + (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) + (bitwise-ior (if vis? SIF_DISABLENOSCROLL 0) + SIF_RANGE + SIF_POS + SIF_PAGE) + 0 (+ len page -1) page pos 0)) + (when hscroll? + (SetScrollInfo canvas-hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t)) + (when vscroll? + (SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)) + (void)) + + (define/override (reset-dc-for-autoscroll) + (reset-dc) + (refresh)) + + (define/override (get-virtual-h-pos) + (GetScrollPos canvas-hwnd SB_HORZ)) + (define/override (get-virtual-v-pos) + (GetScrollPos canvas-hwnd SB_VERT)) + + (define/public (get-scroll-pos which) + (if (is-auto-scroll?) + 0 + (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))) + (define/public (get-scroll-range which) + (if (is-auto-scroll?) + 0 + (get-real-scroll-range which))) + (define/public (get-real-scroll-range which) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (+ (- (SCROLLINFO-nMax i) + (SCROLLINFO-nPage i)) + 1))) + (define/public (get-scroll-page which) + (if (is-auto-scroll?) + 0 + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (SCROLLINFO-nPage i)))) + + (define/public (set-scroll-pos which v) + (void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) + (define/public (set-scroll-range which v) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE + (if (if (eq? which 'vertical) + v-scroll-visible? + h-scroll-visible?) + SIF_DISABLENOSCROLL + 0))) + (set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1)) + (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t) + (void))) + (define/public (set-scroll-page which v) + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE + (if (if (eq? which 'vertical) + v-scroll-visible? + h-scroll-visible?) + SIF_DISABLENOSCROLL + 0))) + (set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) + v)) + (set-SCROLLINFO-nPage! i v) + (SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t) + (void))) + + (define/public (on-scroll e) (void)) + (define/private (on-scroll-change dir part) + (let ([i (GetScrollInfo canvas-hwnd dir)]) + (let ([new-pos + (cond + [(= part SB_TOP) 0] + [(= part SB_BOTTOM) (SCROLLINFO-nMax i)] + [(= part SB_LINEUP) (max 0 (sub1 (SCROLLINFO-nPos i)))] + [(= part SB_LINEDOWN) (min (SCROLLINFO-nMax i) (add1 (SCROLLINFO-nPos i)))] + [(= part SB_PAGEUP) (max 0 (- (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))] + [(= part SB_PAGEDOWN) (min (SCROLLINFO-nMax i) (+ (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))] + [(= part SB_THUMBTRACK) (SCROLLINFO-nTrackPos i)] + [else (SCROLLINFO-nPos i)])]) + (unless (= new-pos (SCROLLINFO-nPos i)) + (set-SCROLLINFO-nPos! i new-pos) + (set-SCROLLINFO-fMask! i SIF_POS) + (SetScrollInfo canvas-hwnd dir i #t) + (if (is-auto-scroll?) + (refresh-for-autoscroll) + (queue-window-event + this + (lambda () + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction (if (= dir SB_HORZ) 'horizontal 'vertical)] + [position new-pos]))))) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void)))))) + + (define/override (wants-mouse-capture? control-hwnd) + (ptr-equal? canvas-hwnd control-hwnd)) + + (define/override (definitely-wants-event? w msg wParam e) + (cond + [(e . is-a? . key-event%) + ;; All key events to canvas, event for combo: + #t] + [(and (or (= wParam HTVSCROLL) + (= wParam HTHSCROLL)) + (or (= msg WM_NCLBUTTONDOWN) + (= msg WM_NCRBUTTONDOWN) + (= msg WM_NCMBUTTONDOWN) + (= msg WM_NCLBUTTONDBLCLK) + (= msg WM_NCRBUTTONDBLCLK) + (= msg WM_NCMBUTTONDBLCLK) + (= msg WM_NCLBUTTONUP) + (= msg WM_NCRBUTTONUP) + (= msg WM_NCMBUTTONUP))) + ;; let scrollbar handle event: + #f] + [else + ;; otherwise, just handle events to canvas: + (ptr-equal? w canvas-hwnd)])) + + (define/public (on-combo-select i) (void)) + (define/public (set-combo-text s) (void)) + (define/public (append-combo-item s) + (SendMessageW/str combo-hwnd CB_ADDSTRING 0 s)) + (define/public (clear-combo-items) + (SendMessageW combo-hwnd CB_RESETCONTENT 0 0)) + + (define/public (on-popup) (void)) + + (define/override (is-command? cmd) + (or (= cmd CBN_SELENDOK) + (= cmd CBN_DROPDOWN))) + + (define/public (do-command cmd control-hwnd) + (cond + [(= cmd CBN_SELENDOK) + (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) + (queue-window-event this (lambda () (on-combo-select i))))] + [(= cmd CBN_DROPDOWN) + (constrained-reply (get-eventspace) (lambda () (on-popup)) (void))])) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? panel-hwnd a-hwnd) + (ptr-equal? canvas-hwnd a-hwnd) + (ptr-equal? combo-hwnd a-hwnd))) + + (define/public (scroll x y) + (when (is-auto-scroll?) + (when (x . >= . 0) + (set-scroll-pos 'horizontal + (->long (* x (get-real-scroll-range 'horizontal))))) + (when (y . >= . 0) + (set-scroll-pos 'vertical + (->long (* y (get-real-scroll-range 'vertical))))) + (refresh-for-autoscroll))) + + (define/public (warp-pointer x y) (void)) + + (define/public (set-resize-corner on?) + (void)) + + (define reg-blits null) + + (define/private (register-one-blit x y w h on-hbitmap off-hbitmap) + (atomically + (let ([hdc (create-gc-dc canvas-hwnd)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc hdc on-hbitmap x y w h) + (make-gc-hide-desc hdc off-hbitmap x y w h))]) + (cons hdc r))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (fix-bitmap-size on w h on-x on-y)] + [off (fix-bitmap-size off w h off-x off-y)]) + (let ([on-hbitmap (bitmap->hbitmap on)] + [off-hbitmap (bitmap->hbitmap off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-hbitmap off-hbitmap) reg-blits)))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (ReleaseDC canvas-hwnd (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null)))))) + + diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt new file mode 100644 index 00000000..3106b450 --- /dev/null +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require racket/class + "../../syntax.rkt" + "button.rkt" + "item.rkt" + "utils.rkt" + "const.rkt") + +(provide + (protect-out check-box%)) + +(define BM_GETCHECK #x00F0) +(define BM_SETCHECK #x00F1) + +(defclass check-box% base-button% + (inherit auto-size + get-hwnd) + + (super-new) + + (define/override (get-flags) (bitwise-ior BS_AUTOCHECKBOX)) + + (define/override (get-button-background) + (GetSysColor COLOR_BTNFACE)) + + (define/override (auto-size-button font label) + (auto-size font label 0 0 20 0)) + + (define/public (set-value v) + (void (SendMessageW (get-hwnd) BM_SETCHECK (if v 1 0) 0))) + + (define/public (get-value) + (positive? (bitwise-and #x3 (SendMessageW (get-hwnd) BM_GETCHECK 0 0))))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt new file mode 100644 index 00000000..b189c0a9 --- /dev/null +++ b/collects/mred/private/wx/win32/choice.rkt @@ -0,0 +1,114 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") + +(provide + (protect-out choice%)) + +(define choice% + (class item% + (init parent cb label + x y w h + choices style font) + (inherit auto-size set-control-font + set-size) + + (define callback cb) + + (define hwnd + (CreateWindowExW/control 0 + "PLTCOMBOBOX" + label + (bitwise-ior WS_CHILD CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define num-choices (length choices)) + + (for ([s (in-list choices)] + [i (in-naturals)]) + (SendMessageW/str hwnd CB_INSERTSTRING i s)) + + (SendMessageW hwnd CB_SETCURSEL 0 0) + + (super-new [callback cb] + [parent parent] + [hwnd hwnd] + [style style]) + + (set-control-font font) + ;; setting the choice height somehow sets the + ;; popup-menu size, not the control that you see + (auto-size font + (if (null? choices) (list "Choice") choices) + 0 0 40 0 + (lambda (w h) + (set-size -11111 -11111 w (* h 8)))) + + + (define choice-dropped? #f) + + (define/override (ctlproc w msg wParam lParam default) + (cond + [(and choice-dropped? + (or (= msg WM_KEYDOWN) + (= msg WM_KEYUP) + (= msg WM_SYSCHAR) + (= msg WM_CHAR))) + (default w msg wParam lParam)] + [else (super ctlproc w msg wParam lParam default)])) + + (define/override (is-command? cmd) + (when (= cmd CBN_DROPDOWN) + (set! choice-dropped? #t)) + (when (= cmd CBN_CLOSEUP) + (queue-window-event this (lambda () + (set! choice-dropped? #f)))) + (= cmd CBN_SELENDOK)) + + (define/public (do-command cmd control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))))) + + + (define/public (set-selection i) + (void (SendMessageW hwnd CB_SETCURSEL i 0))) + + (define/public (get-selection) + (SendMessageW hwnd CB_GETCURSEL 0 0)) + + (define/public (number) num-choices) + + (define/public (clear) + (atomically + (SendMessageW hwnd CB_RESETCONTENT 0 0) + (set! num-choices 0))) + + + (public [append* append]) + (define (append* str) + (atomically + (SendMessageW/str hwnd CB_ADDSTRING 0 str) + (set! num-choices (add1 num-choices)) + (when (= 1 num-choices) (set-selection 0)))))) + + + diff --git a/collects/mred/private/wx/win32/clipboard.rkt b/collects/mred/private/wx/win32/clipboard.rkt new file mode 100644 index 00000000..bf16d1dc --- /dev/null +++ b/collects/mred/private/wx/win32/clipboard.rkt @@ -0,0 +1,260 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc + racket/draw/unsafe/bstr + "../common/queue.rkt" + "../../lock.rkt" + "types.rkt" + "utils.rkt" + "const.rkt" + "../../syntax.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "../common/local.rkt") + +(provide + (protect-out clipboard-driver% + has-x-selection?)) + +(define (has-x-selection?) #f) + +;; Dummy window to own the clipboard: +(define clipboard-owner-hwnd + (CreateWindowExW 0 "PLTFrame" "" + WS_POPUP + 0 0 10 10 + #f + #f + hInstance + #f)) + +(define CF_UNICODETEXT 13) +(define CF_BITMAP 2) +(define CF_DIB 8) + +(define DIB_RGB_COLORS 0) +(define SRCCOPY #x00CC0020) + +(define-cstruct _BITMAPINFOHEADER + ([biSize _DWORD] + [biWidth _LONG] + [biHeight _LONG] + [biPlanes _WORD] + [biBitCount _WORD] + [biCompression _DWORD] + [biSizeImage _DWORD] + [biXPelsPerMeter _LONG] + [biYPelsPerMeter _LONG] + [biClrUsed _DWORD] + [biClrImportant _DWORD])) + +(define-cstruct _BITMAPCOREHEADER + ([bcSize _DWORD] + [bcWidth _LONG] + [bcHeight _LONG] + [bcPlanes _WORD] + [bcBitCount _WORD])) + +(define-user32 GetClipboardOwner (_wfun -> _HWND)) +(define-user32 OpenClipboard (_wfun _HWND -> _BOOL)) +(define-user32 CloseClipboard (_wfun -> _BOOL)) +(define-user32 EmptyClipboard (_wfun -> (r : _BOOL) -> (unless r (failed 'EmptyClipboard)))) + +(define-user32 RegisterClipboardFormatW (_wfun _string/utf-16 -> (r : _UINT) + -> (if (zero? r) + (failed 'RegisterClipboardFormatW) + r))) + +(define-kernel32 GlobalFree (_wfun _HANDLE -> (r : _HANDLE) + -> (unless r (failed 'GlobalFree))) + #:wrap (deallocator)) +(define-kernel32 GlobalAlloc (_wfun _UINT _SIZE_T -> (r : _HANDLE) + -> (or r (failed 'GlobalAlloc))) + #:wrap (allocator GlobalFree)) + +(define-kernel32 GlobalLock (_wfun _HANDLE -> (r : _pointer) + -> (or r (failed 'GlobalLock)))) +(define-kernel32 GlobalUnlock (_wfun _HANDLE -> _BOOL)) +(define-kernel32 GlobalSize (_wfun _HANDLE -> (r : _SIZE_T) + -> (if (zero? r) + (failed 'GlobalSize) + r))) + +(define-user32 SetClipboardData (_wfun _UINT _HANDLE -> (r : _HANDLE) + -> (unless r (failed 'SetClipboardData))) + ;; SetClipboardData accepts responsibility for the handle: + #:wrap (deallocator cadr)) + +(define-user32 GetClipboardData (_wfun _UINT -> _HANDLE)) + +(define-gdi32 StretchDIBits(_wfun _HDC _int _int _int _int _int _int _int _int + _pointer _BITMAPINFOHEADER-pointer _UINT _DWORD + -> _int)) + +(define GHND #x0042) + +(defclass clipboard-driver% object% + (init x-selection?) ; always #f + + (define client #f) + (define counter -1) + + (define/public (clear-client) + ;; called in event-pump thread + (set! client #f)) + + (define/public (get-client) + (and client + (if (ptr-equal? clipboard-owner-hwnd + (GetClipboardOwner)) + client + (let ([c client]) + (set! client #f) + (drop-client c) + #f)))) + + (define/private (drop-client c) + (queue-event (send c get-client-eventspace) + (lambda () + (send c on-replaced)))) + + (define/public (set-client c types) + (let* ([type-ids (for/list ([t (in-list types)]) + (if (string=? t "TEXT") + CF_UNICODETEXT + (RegisterClipboardFormatW t)))] + [all-data (for/list ([t (in-list types)] + [t-id (in-list type-ids)]) + (let ([d (send c get-data t)]) + (cond + [(equal? t-id CF_UNICODETEXT) + ;; convert UTF-8 to UTF-16: + (let ([p (cast (bytes->string/utf-8 d #\?) + _string/utf-16 + _gcpointer)]) + (let ([len (let loop ([i 0]) + (if (and (zero? (ptr-ref p _byte i)) + (zero? (ptr-ref p _byte (add1 i)))) + (+ i 2) + (loop (+ i 2))))]) + (scheme_make_sized_byte_string p + len + 0)))] + [else + ;; no conversion: + d])))] + [all-handles (for/list ([d (in-list all-data)]) + (let ([h (GlobalAlloc GHND (bytes-length d))]) + (let ([p (GlobalLock h)]) + (memcpy p d (bytes-length d))) + (GlobalUnlock h) + h))]) + (if (null? types) + (drop-client c) + (atomically + (if (OpenClipboard clipboard-owner-hwnd) + (begin + (EmptyClipboard) + (for ([t (in-list type-ids)] + [h (in-list all-handles)]) + (SetClipboardData t h)) + (if (CloseClipboard) + (set! client c) + (drop-client c))) + (drop-client c)))))) + + (define/public (get-data format [as-text? #f]) + (let ([t (if (string=? format "TEXT") + CF_UNICODETEXT + (RegisterClipboardFormatW format))]) + (atomically + (and (OpenClipboard clipboard-owner-hwnd) + (let ([d (GetClipboardData t)]) + (begin0 + (and d + (let ([hsize (GlobalSize d)] + [p (GlobalLock d)]) + (begin0 + (if as-text? + (cast p _pointer _string/utf-16) + (scheme_make_sized_byte_string p hsize 1)) + (GlobalUnlock d)))) + (CloseClipboard))))))) + + (define/public (get-text-data) + (or (get-data "TEXT" #t) "")) + + (define/public (get-bitmap-data) + (atomically + (and (OpenClipboard clipboard-owner-hwnd) + (begin0 + (get-bitmap-from-clipboard) + (CloseClipboard))))) + + (super-new)) + + +(define (get-bitmap-from-clipboard) + ;; atomic mode + (cond + ;; I think we should be able to use CF_BITMAP always, but + ;; it doesn't work right under Windows XP with a particular + ;; image created by copying in Firefox. So, we do things the + ;; hard way. + [(GetClipboardData CF_DIB) + => (lambda (bits) + (let ([bmi (cast (GlobalLock bits) _pointer _BITMAPINFOHEADER-pointer)]) + (let ([w (BITMAPINFOHEADER-biWidth bmi)] + [h (BITMAPINFOHEADER-biHeight bmi)] + [bits/pp (BITMAPINFOHEADER-biBitCount bmi)]) + (let* ([screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [hbitmap (if (= bits/pp 1) + (CreateBitmap w h 1 1 #f) + (CreateCompatibleBitmap screen-hdc w h))] + [old-hbitmap (SelectObject hdc hbitmap)] + [psize (PaletteSize bmi)]) + (ReleaseDC #f screen-hdc) + (StretchDIBits hdc 0 0 w h + 0 0 w h + (ptr-add bmi (+ (BITMAPINFOHEADER-biSize bmi) psize)) + bmi DIB_RGB_COLORS SRCCOPY) + (SelectObject hdc old-hbitmap) + (GlobalUnlock bits) + (DeleteDC hdc) + (begin0 + (hbitmap->bitmap hbitmap) + (DeleteObject hbitmap))))))] + [(GetClipboardData CF_BITMAP) + => (lambda (hbitmap) + (hbitmap->bitmap hbitmap))] + [else #f])) + +;; Copied from MS example: + +(define (DibNumColors bmc? bmi) + ;; /* With the BITMAPINFO format headers, the size of the palette + ;; * is in biClrUsed, whereas in the BITMAPCORE - style headers, it + ;; * is dependent on the bits per pixel ( = 2 raised to the power of + ;; * bits/pixel). + ;; */ + (if (and (not bmc?) + (not (zero? (BITMAPINFOHEADER-biClrUsed bmi)))) + (BITMAPINFOHEADER-biClrUsed bmi) + (let ([bits (BITMAPINFOHEADER-biBitCount bmi)]) + (case bits + [(1) 2] + [(4) 16] + [(8) 256] + [else + ;; A 24 bitcount DIB has no color table + 0])))) + +(define (PaletteSize bmi) + (let* ([bmc? (= (BITMAPINFOHEADER-biSize bmi) + (ctype-sizeof _BITMAPCOREHEADER))] + [num-colors (DibNumColors bmc? bmi)]) + (if bmc? + (* num-colors 3) + (* num-colors 4)))) diff --git a/collects/mred/private/wx/win32/colordialog.rkt b/collects/mred/private/wx/win32/colordialog.rkt new file mode 100644 index 00000000..8a99959c --- /dev/null +++ b/collects/mred/private/wx/win32/colordialog.rkt @@ -0,0 +1,53 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/string + racket/draw/private/color + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../../lock.rkt") + +(provide + (protect-out get-color-from-user)) + +(define-cstruct _CHOOSECOLOR + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hInstance _HWND] + [rgbResult _COLORREF] + [lpCustColors _pointer] + [Flags _DWORD] + [lCustData _LPARAM] + [lpfnHook _fpointer] + [lpTemplateName _fpointer])) + +(define CC_RGBINIT #x00000001) + +(define-comdlg32 ChooseColorW (_wfun _CHOOSECOLOR-pointer -> _BOOL)) + +(define custom-colors (malloc 'raw 16 _COLORREF)) +(memset custom-colors 255 16 _COLORREF) + +(define (get-color-from-user message parent color) + (atomically + (let ([p (malloc 'raw _CHOOSECOLOR)]) + (memset p 0 1 _CHOOSECOLOR) + (set-cpointer-tag! p CHOOSECOLOR-tag) + (set-CHOOSECOLOR-lStructSize! p (ctype-sizeof _CHOOSECOLOR)) + (when parent + (set-CHOOSECOLOR-hwndOwner! p (send parent get-hwnd))) + (when color + (set-CHOOSECOLOR-rgbResult! p (make-COLORREF + (color-red color) + (color-green color) + (color-blue color))) + (set-CHOOSECOLOR-Flags! p CC_RGBINIT)) + (set-CHOOSECOLOR-lpCustColors! p custom-colors) + (begin0 + (and (ChooseColorW p) + (let ([c (CHOOSECOLOR-rgbResult p)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + (free p))))) + diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt new file mode 100644 index 00000000..a72df087 --- /dev/null +++ b/collects/mred/private/wx/win32/const.rkt @@ -0,0 +1,626 @@ +#lang racket/base +(provide (all-defined-out)) + +(define WM_NULL #x0000) +(define WM_CREATE #x0001) +(define WM_DESTROY #x0002) +(define WM_MOVE #x0003) +(define WM_SIZE #x0005) + +(define WM_ACTIVATE #x0006) + + +;; WM_ACTIVATE state values +(define WA_INACTIVE 0) +(define WA_ACTIVE 1) +(define WA_CLICKACTIVE 2) + +(define WM_SETFOCUS #x0007) +(define WM_KILLFOCUS #x0008) +(define WM_ENABLE #x000A) +(define WM_SETREDRAW #x000B) +(define WM_SETTEXT #x000C) +(define WM_GETTEXT #x000D) +(define WM_GETTEXTLENGTH #x000E) +(define WM_PAINT #x000F) +(define WM_CLOSE #x0010) +(define WM_QUIT #x0012) +(define WM_ERASEBKGND #x0014) +(define WM_SYSCOLORCHANGE #x0015) +(define WM_SHOWWINDOW #x0018) +(define WM_WININICHANGE #x001A) +(define WM_SETTINGCHANGE WM_WININICHANGE) + +(define WM_DEVMODECHANGE #x001B) +(define WM_ACTIVATEAPP #x001C) +(define WM_FONTCHANGE #x001D) +(define WM_TIMECHANGE #x001E) +(define WM_CANCELMODE #x001F) +(define WM_SETCURSOR #x0020) +(define WM_MOUSEACTIVATE #x0021) +(define WM_CHILDACTIVATE #x0022) +(define WM_QUEUESYNC #x0023) + +(define WM_GETMINMAXINFO #x0024) + +(define WM_PAINTICON #x0026) +(define WM_ICONERASEBKGND #x0027) +(define WM_NEXTDLGCTL #x0028) +(define WM_SPOOLERSTATUS #x002A) +(define WM_DRAWITEM #x002B) +(define WM_MEASUREITEM #x002C) +(define WM_DELETEITEM #x002D) +(define WM_VKEYTOITEM #x002E) +(define WM_CHARTOITEM #x002F) +(define WM_SETFONT #x0030) +(define WM_GETFONT #x0031) +(define WM_SETHOTKEY #x0032) +(define WM_GETHOTKEY #x0033) +(define WM_QUERYDRAGICON #x0037) +(define WM_COMPAREITEM #x0039) +(define WM_GETOBJECT #x003D) +(define WM_COMPACTING #x0041) +(define WM_WINDOWPOSCHANGING #x0046) +(define WM_WINDOWPOSCHANGED #x0047) + +(define WM_POWER #x0048) + +;; wParam for WM_POWER window message and DRV_POWER driver notification +(define PWR_OK 1) +(define PWR_FAIL -1) +(define PWR_SUSPENDREQUEST 1) +(define PWR_SUSPENDRESUME 2) +(define PWR_CRITICALRESUME 3) + +(define WM_COPYDATA #x004A) +(define WM_CANCELJOURNAL #x004B) + +(define WM_NOTIFY #x004E) +(define WM_INPUTLANGCHANGEREQUEST #x0050) +(define WM_INPUTLANGCHANGE #x0051) +(define WM_TCARD #x0052) +(define WM_HELP #x0053) +(define WM_USERCHANGED #x0054) +(define WM_NOTIFYFORMAT #x0055) + +(define NFR_ANSI 1) +(define NFR_UNICODE 2) +(define NF_QUERY 3) +(define NF_REQUERY 4) + +(define WM_CONTEXTMENU #x007B) +(define WM_STYLECHANGING #x007C) +(define WM_STYLECHANGED #x007D) +(define WM_DISPLAYCHANGE #x007E) +(define WM_GETICON #x007F) +(define WM_SETICON #x0080) + +(define WM_NCCREATE #x0081) +(define WM_NCDESTROY #x0082) +(define WM_NCCALCSIZE #x0083) +(define WM_NCHITTEST #x0084) +(define WM_NCPAINT #x0085) +(define WM_NCACTIVATE #x0086) +(define WM_GETDLGCODE #x0087) +(define WM_NCMOUSEMOVE #x00A0) +(define WM_NCLBUTTONDOWN #x00A1) +(define WM_NCLBUTTONUP #x00A2) +(define WM_NCLBUTTONDBLCLK #x00A3) +(define WM_NCRBUTTONDOWN #x00A4) +(define WM_NCRBUTTONUP #x00A5) +(define WM_NCRBUTTONDBLCLK #x00A6) +(define WM_NCMBUTTONDOWN #x00A7) +(define WM_NCMBUTTONUP #x00A8) +(define WM_NCMBUTTONDBLCLK #x00A9) + +(define WM_NCXBUTTONDOWN #x00AB) +(define WM_NCXBUTTONUP #x00AC) +(define WM_NCXBUTTONDBLCLK #x00AD) + +(define WM_INPUT #x00FF) + +(define WM_KEYFIRST #x0100) +(define WM_KEYDOWN #x0100) +(define WM_KEYUP #x0101) +(define WM_CHAR #x0102) +(define WM_DEADCHAR #x0103) +(define WM_SYSKEYDOWN #x0104) +(define WM_SYSKEYUP #x0105) +(define WM_SYSCHAR #x0106) +(define WM_SYSDEADCHAR #x0107) +(define WM_UNICHAR #x0109) +(define WM_KEYLAST #x0109) +(define UNICODE_NOCHAR #xFFFF) + +(define WM_IME_STARTCOMPOSITION #x010D) +(define WM_IME_ENDCOMPOSITION #x010E) +(define WM_IME_COMPOSITION #x010F) +(define WM_IME_KEYLAST #x010F) + +(define WM_INITDIALOG #x0110) +(define WM_COMMAND #x0111) +(define WM_SYSCOMMAND #x0112) +(define WM_TIMER #x0113) +(define WM_HSCROLL #x0114) +(define WM_VSCROLL #x0115) +(define WM_INITMENU #x0116) +(define WM_INITMENUPOPUP #x0117) +(define WM_MENUSELECT #x011F) +(define WM_MENUCHAR #x0120) +(define WM_ENTERIDLE #x0121) +(define WM_MENURBUTTONUP #x0122) +(define WM_MENUDRAG #x0123) +(define WM_MENUGETOBJECT #x0124) +(define WM_UNINITMENUPOPUP #x0125) +(define WM_MENUCOMMAND #x0126) + +(define WM_CHANGEUISTATE #x0127) +(define WM_UPDATEUISTATE #x0128) +(define WM_QUERYUISTATE #x0129) + +;; LOWORD(wParam) values in WM_*UISTATE* +(define UIS_SET 1) +(define UIS_CLEAR 2) +(define UIS_INITIALIZE 3) + +;; HIWORD(wParam) values in WM_*UISTATE* +(define UISF_HIDEFOCUS #x1) +(define UISF_HIDEACCEL #x2) +(define UISF_ACTIVE #x4) + +(define WM_CTLCOLORMSGBOX #x0132) +(define WM_CTLCOLOREDIT #x0133) +(define WM_CTLCOLORLISTBOX #x0134) +(define WM_CTLCOLORBTN #x0135) +(define WM_CTLCOLORDLG #x0136) +(define WM_CTLCOLORSCROLLBAR #x0137) +(define WM_CTLCOLORSTATIC #x0138) +(define MN_GETHMENU #x01E1) + +(define WM_MOUSEFIRST #x0200) +(define WM_MOUSEMOVE #x0200) +(define WM_LBUTTONDOWN #x0201) +(define WM_LBUTTONUP #x0202) +(define WM_LBUTTONDBLCLK #x0203) +(define WM_RBUTTONDOWN #x0204) +(define WM_RBUTTONUP #x0205) +(define WM_RBUTTONDBLCLK #x0206) +(define WM_MBUTTONDOWN #x0207) +(define WM_MBUTTONUP #x0208) +(define WM_MBUTTONDBLCLK #x0209) +(define WM_MOUSEWHEEL #x020A) +(define WM_XBUTTONDOWN #x020B) +(define WM_XBUTTONUP #x020C) +(define WM_XBUTTONDBLCLK #x020D) +(define WM_MOUSELAST #x020D) + +;; Value for rolling one detent +(define WHEEL_DELTA 120) +;; (define WHEEL_PAGESCROLL UINT_MAX) + +;; XButton values are WORD flags +(define XBUTTON1 #x0001) +(define XBUTTON2 #x0002) + +(define WM_PARENTNOTIFY #x0210) +(define WM_ENTERMENULOOP #x0211) +(define WM_EXITMENULOOP #x0212) + +(define WM_NEXTMENU #x0213) +(define WM_SIZING #x0214) +(define WM_CAPTURECHANGED #x0215) +(define WM_MOVING #x0216) + +(define WM_DEVICECHANGE #x0219) + +(define WM_MDICREATE #x0220) +(define WM_MDIDESTROY #x0221) +(define WM_MDIACTIVATE #x0222) +(define WM_MDIRESTORE #x0223) +(define WM_MDINEXT #x0224) +(define WM_MDIMAXIMIZE #x0225) +(define WM_MDITILE #x0226) +(define WM_MDICASCADE #x0227) +(define WM_MDIICONARRANGE #x0228) +(define WM_MDIGETACTIVE #x0229) + + +(define WM_MDISETMENU #x0230) +(define WM_ENTERSIZEMOVE #x0231) +(define WM_EXITSIZEMOVE #x0232) +(define WM_DROPFILES #x0233) +(define WM_MDIREFRESHMENU #x0234) + + +(define WM_IME_SETCONTEXT #x0281) +(define WM_IME_NOTIFY #x0282) +(define WM_IME_CONTROL #x0283) +(define WM_IME_COMPOSITIONFULL #x0284) +(define WM_IME_SELECT #x0285) +(define WM_IME_CHAR #x0286) +(define WM_IME_REQUEST #x0288) +(define WM_IME_KEYDOWN #x0290) +(define WM_IME_KEYUP #x0291) + +(define WM_MOUSEHOVER #x02A1) +(define WM_MOUSELEAVE #x02A3) +(define WM_NCMOUSEHOVER #x02A0) +(define WM_NCMOUSELEAVE #x02A2) + +(define WM_WTSSESSION_CHANGE #x02B1) + +(define WM_TABLET_FIRST #x02c0) +(define WM_TABLET_LAST #x02df) + +(define WM_CUT #x0300) +(define WM_COPY #x0301) +(define WM_PASTE #x0302) +(define WM_CLEAR #x0303) +(define WM_UNDO #x0304) +(define WM_RENDERFORMAT #x0305) +(define WM_RENDERALLFORMATS #x0306) +(define WM_DESTROYCLIPBOARD #x0307) +(define WM_DRAWCLIPBOARD #x0308) +(define WM_PAINTCLIPBOARD #x0309) +(define WM_VSCROLLCLIPBOARD #x030A) +(define WM_SIZECLIPBOARD #x030B) +(define WM_ASKCBFORMATNAME #x030C) +(define WM_CHANGECBCHAIN #x030D) +(define WM_HSCROLLCLIPBOARD #x030E) +(define WM_QUERYNEWPALETTE #x030F) +(define WM_PALETTEISCHANGING #x0310) +(define WM_PALETTECHANGED #x0311) +(define WM_HOTKEY #x0312) + +(define WM_USER #x0400) + +;; Class styles +(define CS_VREDRAW #x0001) +(define CS_HREDRAW #x0002) +(define CS_DBLCLKS #x0008) +(define CS_OWNDC #x0020) +(define CS_CLASSDC #x0040) +(define CS_PARENTDC #x0080) +(define CS_NOCLOSE #x0200) +(define CS_SAVEBITS #x0800) +(define CS_BYTEALIGNCLIENT #x1000) +(define CS_BYTEALIGNWINDOW #x2000) +(define CS_GLOBALCLASS #x4000) + +;; Window styles +(define WS_OVERLAPPED #x00000000) +(define WS_POPUP #x80000000) +(define WS_CHILD #x40000000) +(define WS_CLIPSIBLINGS #x04000000) +(define WS_CLIPCHILDREN #x02000000) +(define WS_VISIBLE #x10000000) +(define WS_DISABLED #x08000000) +(define WS_MINIMIZE #x20000000) +(define WS_MAXIMIZE #x01000000) +(define WS_CAPTION #x00C00000) +(define WS_BORDER #x00800000) +(define WS_DLGFRAME #x00400000) +(define WS_VSCROLL #x00200000) +(define WS_HSCROLL #x00100000) +(define WS_SYSMENU #x00080000) +(define WS_THICKFRAME #x00040000) +(define WS_MINIMIZEBOX #x00020000) +(define WS_MAXIMIZEBOX #x00010000) +(define WS_GROUP #x00020000) +(define WS_TABSTOP #x00010000) + +(define WS_OVERLAPPEDWINDOW (bitwise-ior WS_OVERLAPPED WS_CAPTION WS_SYSMENU + WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX)) + +(define PM_NOREMOVE #x0000) +(define PM_REMOVE #x0001) +(define PM_NOYIELD #x0002) + +(define QS_KEY #x0001) +(define QS_MOUSEMOVE #x0002) +(define QS_MOUSEBUTTON #x0004) +(define QS_POSTMESSAGE #x0008) +(define QS_TIMER #x0010) +(define QS_PAINT #x0020) +(define QS_SENDMESSAGE #x0040) +(define QS_HOTKEY #x0080) +(define QS_ALLPOSTMESSAGE #x0100) +(define QS_RAWINPUT #x0400) +(define QS_MOUSE (bitwise-ior QS_MOUSEMOVE + QS_MOUSEBUTTON)) + +(define QS_INPUT (bitwise-ior QS_MOUSE + QS_KEY + QS_RAWINPUT)) +(define QS_ALLEVENTS (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY)) + +(define QS_ALLINPUT (bitwise-ior QS_INPUT + QS_POSTMESSAGE + QS_TIMER + QS_PAINT + QS_HOTKEY + QS_SENDMESSAGE)) + +(define GWLP_WNDPROC -4) +(define GWLP_USERDATA -21) + + +(define COLOR_SCROLLBAR 0) +(define COLOR_BACKGROUND 1) +(define COLOR_ACTIVECAPTION 2) +(define COLOR_INACTIVECAPTION 3) +(define COLOR_MENU 4) +(define COLOR_WINDOW 5) +(define COLOR_WINDOWFRAME 6) +(define COLOR_MENUTEXT 7) +(define COLOR_WINDOWTEXT 8) +(define COLOR_CAPTIONTEXT 9) +(define COLOR_ACTIVEBORDER 10) +(define COLOR_INACTIVEBORDER 11) +(define COLOR_APPWORKSPACE 12) +(define COLOR_HIGHLIGHT 13) +(define COLOR_HIGHLIGHTTEXT 14) +(define COLOR_BTNFACE 15) +(define COLOR_BTNSHADOW 16) +(define COLOR_GRAYTEXT 17) +(define COLOR_BTNTEXT 18) +(define COLOR_INACTIVECAPTIONTEXT 19) +(define COLOR_BTNHIGHLIGHT 20) + +(define BS_PUSHBUTTON #x00000000) +(define BS_DEFPUSHBUTTON #x00000001) +(define BS_CHECKBOX #x00000002) +(define BS_AUTOCHECKBOX #x00000003) +(define BS_RADIOBUTTON #x00000004) +(define BS_3STATE #x00000005) +(define BS_AUTO3STATE #x00000006) +(define BS_GROUPBOX #x00000007) +(define BS_USERBUTTON #x00000008) +(define BS_AUTORADIOBUTTON #x00000009) +(define BS_PUSHBOX #x0000000A) +(define BS_OWNERDRAW #x0000000B) +(define BS_TYPEMASK #x0000000F) +(define BS_LEFTTEXT #x00000020) +(define BS_TEXT #x00000000) +(define BS_ICON #x00000040) +(define BS_BITMAP #x00000080) +(define BS_LEFT #x00000100) +(define BS_RIGHT #x00000200) +(define BS_CENTER #x00000300) +(define BS_TOP #x00000400) +(define BS_BOTTOM #x00000800) +(define BS_VCENTER #x00000C00) +(define BS_PUSHLIKE #x00001000) +(define BS_MULTILINE #x00002000) +(define BS_NOTIFY #x00004000) +(define BS_FLAT #x00008000) +(define BS_RIGHTBUTTON BS_LEFTTEXT) + +(define CW_USEDEFAULT (- #x80000000)) ; minus sign => int instead of uint + +(define WS_EX_LAYERED #x00080000) +(define WS_EX_TRANSPARENT #x00000020) + +(define LWA_ALPHA #x00000002) + +(define MB_OK #x00000000) +(define MB_OKCANCEL #x00000001) +(define MB_ABORTRETRYIGNORE #x00000002) +(define MB_YESNOCANCEL #x00000003) +(define MB_YESNO #x00000004) +(define MB_RETRYCANCEL #x00000005) + +(define SIZE_RESTORED 0) +(define SIZE_MINIMIZED 1) +(define SIZE_MAXIMIZED 2) +(define SIZE_MAXSHOW 3) +(define SIZE_MAXHIDE 4) + +(define SB_LINEUP 0) +(define SB_LINELEFT 0) +(define SB_LINEDOWN 1) +(define SB_LINERIGHT 1) +(define SB_PAGEUP 2) +(define SB_PAGELEFT 2) +(define SB_PAGEDOWN 3) +(define SB_PAGERIGHT 3) +(define SB_THUMBPOSITION 4) +(define SB_THUMBTRACK 5) +(define SB_TOP 6) +(define SB_LEFT 6) +(define SB_BOTTOM 7) +(define SB_RIGHT 7) +(define SB_ENDSCROLL 8) + +(define SB_HORZ 0) +(define SB_VERT 1) +(define SB_CTL 2) +(define SB_BOTH 3) + +(define SIF_RANGE #x0001) +(define SIF_PAGE #x0002) +(define SIF_POS #x0004) +(define SIF_DISABLENOSCROLL #x0008) +(define SIF_TRACKPOS #x0010) +(define SIF_ALL (bitwise-ior SIF_RANGE SIF_PAGE SIF_POS SIF_TRACKPOS)) + +(define VK_LBUTTON #x01) +(define VK_RBUTTON #x02) +(define VK_CANCEL #x03) +(define VK_MBUTTON #x04) +(define VK_XBUTTON1 #x05) +(define VK_XBUTTON2 #x06) +(define VK_BACK #x08) +(define VK_TAB #x09) +(define VK_CLEAR #x0C) +(define VK_RETURN #x0D) +(define VK_SHIFT #x10) +(define VK_CONTROL #x11) +(define VK_MENU #x12) +(define VK_PAUSE #x13) +(define VK_CAPITAL #x14) +(define VK_KANA #x15) +(define VK_HANGUL #x15) +(define VK_JUNJA #x17) +(define VK_FINAL #x18) +(define VK_HANJA #x19) +(define VK_KANJI #x19) +(define VK_ESCAPE #x1B) +(define VK_CONVERT #x1C) +(define VK_NONCONVERT #x1D) +(define VK_ACCEPT #x1E) +(define VK_MODECHANGE #x1F) +(define VK_SPACE #x20) +(define VK_PRIOR #x21) +(define VK_NEXT #x22) +(define VK_END #x23) +(define VK_HOME #x24) +(define VK_LEFT #x25) +(define VK_UP #x26) +(define VK_RIGHT #x27) +(define VK_DOWN #x28) +(define VK_SELECT #x29) +(define VK_PRINT #x2A) +(define VK_EXECUTE #x2B) +(define VK_SNAPSHOT #x2C) +(define VK_INSERT #x2D) +(define VK_DELETE #x2E) +(define VK_HELP #x2F) +(define VK_LWIN #x5B) +(define VK_RWIN #x5C) +(define VK_APPS #x5D) +(define VK_SLEEP #x5F) +(define VK_NUMPAD0 #x60) +(define VK_NUMPAD1 #x61) +(define VK_NUMPAD2 #x62) +(define VK_NUMPAD3 #x63) +(define VK_NUMPAD4 #x64) +(define VK_NUMPAD5 #x65) +(define VK_NUMPAD6 #x66) +(define VK_NUMPAD7 #x67) +(define VK_NUMPAD8 #x68) +(define VK_NUMPAD9 #x69) +(define VK_MULTIPLY #x6A) +(define VK_ADD #x6B) +(define VK_SEPARATOR #x6C) +(define VK_SUBTRACT #x6D) +(define VK_DECIMAL #x6E) +(define VK_DIVIDE #x6F) +(define VK_F1 #x70) +(define VK_F2 #x71) +(define VK_F3 #x72) +(define VK_F4 #x73) +(define VK_F5 #x74) +(define VK_F6 #x75) +(define VK_F7 #x76) +(define VK_F8 #x77) +(define VK_F9 #x78) +(define VK_F10 #x79) +(define VK_F11 #x7A) +(define VK_F12 #x7B) +(define VK_F13 #x7C) +(define VK_F14 #x7D) +(define VK_F15 #x7E) +(define VK_F16 #x7F) +(define VK_F17 #x80) +(define VK_F18 #x81) +(define VK_F19 #x82) +(define VK_F20 #x83) +(define VK_F21 #x84) +(define VK_F22 #x85) +(define VK_F23 #x86) +(define VK_F24 #x87) +(define VK_NUMLOCK #x90) +(define VK_SCROLL #x91) +(define VK_LSHIFT #xA0) +(define VK_RSHIFT #xA1) +(define VK_LCONTROL #xA2) +(define VK_RCONTROL #xA3) +(define VK_LMENU #xA4) +(define VK_RMENU #xA5) +(define VK_OEM_1 #xBA) +(define VK_OEM_PLUS #xBB) +(define VK_OEM_COMMA #xBC) +(define VK_OEM_MINUS #xBD) +(define VK_OEM_PERIOD #xBE) +(define VK_OEM_2 #xBF) +(define VK_OEM_3 #xC0) +(define VK_OEM_4 #xDB) +(define VK_OEM_5 #xDC) +(define VK_OEM_6 #xDD) +(define VK_OEM_7 #xDE) +(define VK_OEM_8 #xDF) + +(define KF_EXTENDED #x0100) +(define KF_DLGMODE #x0800) +(define KF_MENUMODE #x1000) +(define KF_ALTDOWN #x2000) +(define KF_REPEAT #x4000) +(define KF_UP #x8000) + +(define GW_HWNDFIRST 0) +(define GW_HWNDLAST 1) +(define GW_HWNDNEXT 2) +(define GW_HWNDPREV 3) +(define GW_OWNER 4) +(define GW_CHILD 5) + +(define MF_INSERT #x00000000) +(define MF_CHANGE #x00000080) +(define MF_APPEND #x00000100) +(define MF_DELETE #x00000200) +(define MF_REMOVE #x00001000) +(define MF_BYCOMMAND #x00000000) +(define MF_BYPOSITION #x00000400) +(define MF_SEPARATOR #x00000800) +(define MF_ENABLED #x00000000) +(define MF_GRAYED #x00000001) +(define MF_DISABLED #x00000002) +(define MF_UNCHECKED #x00000000) +(define MF_CHECKED #x00000008) +(define MF_USECHECKBITMAPS #x00000200) +(define MF_STRING #x00000000) +(define MF_BITMAP #x00000004) +(define MF_OWNERDRAW #x00000100) +(define MF_POPUP #x00000010) +(define MF_MENUBARBREAK #x00000020) +(define MF_MENUBREAK #x00000040) +(define MF_UNHILITE #x00000000) +(define MF_HILITE #x00000080) + +(define BM_SETIMAGE #x00F7) +(define IMAGE_BITMAP 0) +(define BN_CLICKED 0) + +(define SW_SHOW 5) +(define SW_HIDE 0) +(define SW_SHOWNORMAL 1) +(define SW_SHOWMINIMIZED 2) +(define SW_SHOWMAXIMIZED 3) +(define SW_MAXIMIZE 3) +(define SW_SHOWNOACTIVATE 4) +(define SW_MINIMIZE 6) +(define SW_SHOWMINNOACTIVE 7) +(define SW_RESTORE 9) +(define SW_SHOWDEFAULT 10) +(define SW_FORCEMINIMIZE 11) + +(define HORZRES 8) +(define VERTRES 10) + +(define CBS_DROPDOWNLIST #x0003) +(define CB_INSERTSTRING #x014A) +(define CB_SETCURSEL #x014E) +(define CB_GETCURSEL #x0147) +(define CB_ADDSTRING #x0143) +(define CB_RESETCONTENT #x014B) + +(define CBN_SELENDOK 9) +(define CBN_DROPDOWN 7) +(define CBN_CLOSEUP 8) +(define CBN_SELENDCANCEL 10) + diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt new file mode 100644 index 00000000..b49bec95 --- /dev/null +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -0,0 +1,114 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../common/cursor-draw.rkt" + "../../syntax.rkt") + +(provide + (protect-out cursor-driver% + get-arrow-cursor + get-wait-cursor)) + +(define (MAKEINTRESOURCE v) v) + +(define IDC_ARROW (MAKEINTRESOURCE 32512)) +(define IDC_IBEAM (MAKEINTRESOURCE 32513)) +(define IDC_WAIT (MAKEINTRESOURCE 32514)) +(define IDC_APPSTARTING (MAKEINTRESOURCE 32650)) +(define IDC_CROSS (MAKEINTRESOURCE 32515)) +(define IDC_UPARROW (MAKEINTRESOURCE 32516)) +(define IDC_SIZENWSE (MAKEINTRESOURCE 32642)) +(define IDC_SIZENESW (MAKEINTRESOURCE 32643)) +(define IDC_SIZEWE (MAKEINTRESOURCE 32644)) +(define IDC_SIZENS (MAKEINTRESOURCE 32645)) +(define IDC_SIZEALL (MAKEINTRESOURCE 32646)) +(define IDC_NO (MAKEINTRESOURCE 32648)) +(define IDC_HAND (MAKEINTRESOURCE 32649)) +(define IDC_HELP (MAKEINTRESOURCE 32651)) + +(define-user32 LoadCursorW (_wfun _HINSTANCE _LONG -> _HCURSOR)) + +(define-user32 CreateCursor (_wfun _HINSTANCE + _int ; x + _int ; y + _int ; width + _int ; height + _pointer ; AND + _pointer ; XOR + -> _HCURSOR)) + +(define handles (make-hasheq)) +(define (load-cursor num) + (or (hash-ref handles num #f) + (let ([h (LoadCursorW #f num)]) + (hash-set! handles num h) + h))) + +(define (get-arrow-cursor) + (load-cursor IDC_ARROW)) +(define (get-wait-cursor) + (load-cursor IDC_APPSTARTING)) + +(defclass cursor-driver% object% + (define handle #f) + + (define/public (set-standard sym) + (case sym + [(arrow) + (set! handle (load-cursor IDC_ARROW))] + [(cross) + (set! handle (load-cursor IDC_CROSS))] + [(hand) + (set! handle (load-cursor IDC_HAND))] + [(ibeam) + (set! handle (load-cursor IDC_IBEAM))] + [(size-n/s) + (set! handle (load-cursor IDC_SIZENS))] + [(size-e/w) + (set! handle (load-cursor IDC_SIZEWE))] + [(size-nw/se) + (set! handle (load-cursor IDC_SIZENWSE))] + [(size-ne/sw) + (set! handle (load-cursor IDC_SIZENESW))] + [(watch) + (set! handle (load-cursor IDC_APPSTARTING))] + [(bullseye) + (set-image (make-cursor-image draw-bullseye 'unsmoothed) #f 8 8)] + [(blank) + (set-image #f #f 0 0)])) + + (define/public (set-image image mask hot-spot-x hot-spot-y + [ai (make-bytes (/ (* 16 16) 8) 255)] + [xi (make-bytes (/ (* 16 16) 8) 0)]) + (let ([s (make-bytes (* 16 16 4) 0)]) + (when image + (send image get-argb-pixels 0 0 16 16 s) + (if mask + (send mask get-argb-pixels 0 0 16 16 s #t) + (send image get-argb-pixels 0 0 16 16 s #t))) + (for* ([i (in-range 16)] + [j (in-range 16)]) + (let ([pos (* 4 (+ (* j 16) i))]) + (when (positive? (bytes-ref s pos)) + ;; black bit in mask + (let ([bpos (+ (* j (/ 16 8)) (quotient i 8))] + [bit (arithmetic-shift 1 (- 7 (modulo i 8)))]) + (bytes-set! ai bpos (- (bytes-ref ai bpos) bit)) + (unless (and (zero? (bytes-ref s (+ 1 pos))) + (zero? (bytes-ref s (+ 2 pos))) + (zero? (bytes-ref s (+ 3 pos)))) + ;; white cursor pixel + (bytes-set! xi bpos (+ (bytes-ref xi bpos) bit))))))) + (set! handle + (CreateCursor hInstance hot-spot-x hot-spot-y + 16 16 + ai xi)))) + + (define/public (ok?) (and handle #t)) + (define/public (get-handle) handle) + + (super-new)) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt new file mode 100644 index 00000000..db260240 --- /dev/null +++ b/collects/mred/private/wx/win32/dc.rkt @@ -0,0 +1,142 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "gl-context.rkt" + "../../lock.rkt" + "../common/backing-dc.rkt" + "../common/delay.rkt" + racket/draw/unsafe/cairo + racket/draw/private/dc + racket/draw/private/bitmap + racket/draw/private/local + ffi/unsafe/alloc) + +(provide + (protect-out dc% + win32-bitmap% + do-backing-flush + request-flush-delay + cancel-flush-delay)) + +(define win32-bitmap% + (class bitmap% + (init w h hwnd [gl-config #f]) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define s + (let ([s + (if (not hwnd) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC hwnd)]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hwnd hdc)))))]) + ;; initialize bitmap to white: + (let ([cr (cairo_create s)]) + (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) + (cairo_paint cr) + (cairo_destroy cr)) + s)) + + (define gl (and gl-config + (let ([hdc (cairo_win32_surface_get_dc s)]) + (set-cpointer-tag! hdc 'HDC) + (create-gl-context hdc + gl-config + #t)))) + (define/override (get-bitmap-gl-context) gl) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (set! s #f))))) + +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (inherit end-delay) + (define canvas cnvs) + + (super-new) + + (define gl #f) + (define/override (get-gl-context) + (or gl + (let ([v (create-gl-context (GetDC (send canvas get-client-hwnd)) + (send canvas get-gl-config) + #f)]) + (when v (set! gl v)) + v))) + + + (define/override (make-backing-bitmap w h) + (if (send canvas get-canvas-background) + (make-object win32-bitmap% w h (send canvas get-hwnd)) + (super make-backing-bitmap w h))) + + (define/override (get-backing-size xb yb) + (send canvas get-client-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) + (send canvas queue-backing-flush)) + + (define/override (flush) + (send canvas flush)) + + (define/override (request-delay) + (request-flush-delay canvas)) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) + +(define (do-backing-flush canvas dc hdc) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let* ([surface (cairo_win32_surface_create hdc)] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) + +(define (request-flush-delay canvas) + (do-request-flush-delay + canvas + (lambda (gtk) + (send canvas suspend-paint-handling)) + (lambda (gtk) + (send canvas resume-paint-handling)))) + +(define (cancel-flush-delay req) + (when req + (do-cancel-flush-delay + req + (lambda (canvas) + (send canvas resume-paint-handling))))) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt new file mode 100644 index 00000000..18ed2593 --- /dev/null +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require racket/class + (only-in racket/list last) + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "../common/freeze.rkt" + "../common/dialog.rkt" + "utils.ss" + "const.ss" + "types.ss" + "window.rkt" + "frame.rkt" + "wndclass.rkt") + +(provide dialog%) + +(define-cstruct _DLGTEMPLATE + ([style _DWORD] + [dwExtendedStyle _DWORD] + [cdit _WORD] + [x _short] + [y _short] + [cx _short] + [cy _short] + [menu _short] ; 0 + [class _short] ; 0 + [title _short])) ; 0 + +(define DS_MODALFRAME #x80) + +(define dialog% + (class (dialog-mixin frame%) + (super-new) + + (define/override (create-frame parent label x y w h style) + (let ([hwnd + (CreateDialogIndirectParamW hInstance + (make-DLGTEMPLATE + (bitwise-ior DS_MODALFRAME WS_CAPTION WS_SYSMENU WS_THICKFRAME) + 0 0 + 0 0 w h + 0 0 0) + (and parent (send parent get-hwnd)) + dialog-proc + 0)]) + (SetWindowTextW hwnd label) + (let ([x (if (= x -11111) 0 x)] + [y (if (= y -11111) 0 y)]) + (MoveWindow hwnd x y w h #t)) + hwnd)) + + (define/override (is-dialog?) #t))) diff --git a/collects/mred/private/wx/win32/filedialog.rkt b/collects/mred/private/wx/win32/filedialog.rkt new file mode 100644 index 00000000..df03b2ca --- /dev/null +++ b/collects/mred/private/wx/win32/filedialog.rkt @@ -0,0 +1,226 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/string + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../../lock.rkt") + +(provide + (protect-out file-selector)) + +(define-cstruct _OPENFILENAME + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hInstance _HINSTANCE] + [lpstrFilter _permanent-string/utf-16] + [lpstrCustomFilter _permanent-string/utf-16] + [nMaxCustFilter _DWORD] + [nFilterIndex _DWORD] + [lpstrFile _pointer] + [nMaxFile _DWORD] + [lpstrFileTitle _pointer] + [nMaxFileTitle _DWORD] + [lpstrInitialDir _permanent-string/utf-16] + [lpstrTitle _permanent-string/utf-16] + [Flags _DWORD] + [nFileOffset _WORD] + [nFileExtension _WORD] + [lpstrDefExt _permanent-string/utf-16] + [lCustData _LPARAM] + [lpfnHook _fpointer] + [lpTemplateName _permanent-string/utf-16] + [pvReserved _pointer] + [dwReserved _DWORD] + [FlagsEx _DWORD])) + +(define-comdlg32 GetSaveFileNameW (_wfun _OPENFILENAME-pointer -> _BOOL)) +(define-comdlg32 GetOpenFileNameW (_wfun _OPENFILENAME-pointer -> _BOOL)) + +(define OFN_READONLY #x00000001) +(define OFN_OVERWRITEPROMPT #x00000002) +(define OFN_HIDEREADONLY #x00000004) +(define OFN_NOCHANGEDIR #x00000008) +(define OFN_SHOWHELP #x00000010) +(define OFN_ENABLEHOOK #x00000020) +(define OFN_ENABLETEMPLATE #x00000040) +(define OFN_ENABLETEMPLATEHANDLE #x00000080) +(define OFN_ALLOWMULTISELECT #x00000200) +(define OFN_EXTENSIONDIFFERENT #x00000400) +(define OFN_PATHMUSTEXIST #x00000800) +(define OFN_FILEMUSTEXIST #x00001000) +(define OFN_NOREADONLYRETURN #x00008000) +(define OFN_EXPLORER #x00080000) + +(define BUFFER-LEN 4096) + +(define-cstruct _BROWSEINFO + ([hwndOwner _HWND] + [pidlRoot _pointer] + [pszDisplayName _pointer] + [lpszTitle _permanent-string/utf-16] + [ulFlags _UINT] + [lpfn _pointer] + [lParam _LPARAM] + [iImage _int])) + +(define BIF_RETURNONLYFSDIRS #x00000001) +(define BIF_NEWDIALOGSTYLE #x00000040) + +(define-cstruct _IUnknownVtbl + ([QueryInterface _fpointer] + [AddRef _fpointer] + [Release (_wfun _pointer -> _ULONG)])) + +(define-cstruct (_IMallocVtbl _IUnknownVtbl) + ([Alloc _fpointer] + [Realloc _fpointer] + [Free (_wfun _pointer _pointer -> _void)] + [GetSize _fpointer] + [DidAlloc _fpointer] + [HeapMinimize _fpointer])) + +(define-cstruct _IMalloc + ([vtbl _IMallocVtbl-pointer])) + +(define (IMalloc-Free im p) + ((IMallocVtbl-Free (IMalloc-vtbl im)) im p)) +(define (IMalloc-Release im) + ((IUnknownVtbl-Release (IMalloc-vtbl im)) im)) + +(define-shell32 SHBrowseForFolderW (_wfun _BROWSEINFO-pointer -> _pointer)) +(define-shell32 SHGetPathFromIDListW (_wfun _pointer _pointer -> _BOOL)) +(define-shell32 SHGetMalloc (_wfun (p : (_ptr o _IMalloc-pointer)) -> (r : _HRESULT) + -> (if (negative? r) + (error 'SHGetMalloc "failed: ~s" (bitwise-and #xFFFF r)) + p))) + +(define (file-selector message directory filename + extension + filters style parent) + (if (memq 'dir style) + (dialog-selector message directory + style parent) + (do-file-selector message directory filename + extension + filters style parent))) + +(define (do-file-selector message directory filename + extension + filters style parent) + (atomically + (let* ([pre-ofn + (make-OPENFILENAME + (ctype-sizeof _OPENFILENAME) + (and parent + (send parent get-hwnd)) + hInstance + (string-append + (string-join + (for/list ([f (in-list filters)]) + (format "~a\0~a" (car f) (cadr f))) + "\0") + "\0") + #f + 0 + 0 ; nFilterIndex + (malloc 'raw (* BUFFER-LEN (ctype-sizeof _short))) + BUFFER-LEN + #f + 0 + (and directory + (path->string (simplify-path directory #f))) + message + (bitwise-ior + OFN_HIDEREADONLY + (if (memq 'put style) OFN_OVERWRITEPROMPT 0) + (if (memq 'multi style) (bitwise-ior OFN_ALLOWMULTISELECT OFN_EXPLORER) 0) + (if directory OFN_NOCHANGEDIR 0)) + 0 + 0 + extension + 0 + #f + #f + #f + 0 + 0)] + [ofn (malloc 'raw (ctype-sizeof _OPENFILENAME))]) + (set-cpointer-tag! ofn OPENFILENAME-tag) + (memcpy ofn pre-ofn 1 _OPENFILENAME) + (if filename + (let* ([filename (path->string (simplify-path filename #f))] + [len (utf-16-length filename)]) + (memcpy (OPENFILENAME-lpstrFile ofn) + (cast filename _string/utf-16 _gcpointer) + (+ len 1) + _uint16)) + (ptr-set! (OPENFILENAME-lpstrFile ofn) _uint16 0)) + (let ([r (if (memq 'put style) + (GetSaveFileNameW ofn) + (GetOpenFileNameW ofn))]) + (begin0 + (and r + (if (memq 'multi style) + (let ([strs + (let ([p (OPENFILENAME-lpstrFile ofn)]) + (let loop ([pos 0]) + (cond + [(and (zero? (ptr-ref p _byte pos)) + (zero? (ptr-ref p _byte (add1 pos)))) + null] + [else (let ([end-pos + (let loop ([pos (+ pos 2)]) + (cond + [(and (zero? (ptr-ref p _byte pos)) + (zero? (ptr-ref p _byte (add1 pos)))) + pos] + [else (loop (+ pos 2))]))]) + (cons + (cast (ptr-add p pos) _pointer _string/utf-16) + (loop (+ end-pos 2))))])))]) + (if ((length strs) . < . 2) + #f + (map (lambda (p) (build-path (car strs) p)) + (cdr strs)))) + (cast (OPENFILENAME-lpstrFile ofn) _pointer _string/utf-16))) + (when directory + (free (OPENFILENAME-lpstrInitialDir ofn))) + (when message + (free (OPENFILENAME-lpstrTitle ofn))) + (free (OPENFILENAME-lpstrFilter ofn)) + (free (OPENFILENAME-lpstrFile ofn))))))) + +(define MAX_PATH 4096) + +(define (dialog-selector message directory + style parent) + (atomically + (let ([pre-bi (make-BROWSEINFO + (and parent + (send parent get-hwnd)) + #f + (malloc 'raw MAX_PATH _uint16) + message + (bitwise-ior BIF_NEWDIALOGSTYLE BIF_RETURNONLYFSDIRS) + #f + 0 + 0)] + [bi (malloc 'raw (ctype-sizeof _BROWSEINFO))]) + (set-cpointer-tag! bi BROWSEINFO-tag) + (memcpy bi pre-bi 1 _BROWSEINFO) + (let ([r (SHBrowseForFolderW bi)]) + (begin0 + (and r + (let ([ok (SHGetPathFromIDListW r (BROWSEINFO-pszDisplayName bi))]) + (and ok + (let ([mi (SHGetMalloc)]) + (IMalloc-Free mi r) + (IMalloc-Release mi)) + (string->path + (cast (BROWSEINFO-pszDisplayName bi) _pointer _string/utf-16))))) + (free (BROWSEINFO-pszDisplayName bi)) + (when message + (free (BROWSEINFO-lpszTitle bi)))))))) diff --git a/collects/mred/private/wx/win32/font.rkt b/collects/mred/private/wx/win32/font.rkt new file mode 100644 index 00000000..cf7a4616 --- /dev/null +++ b/collects/mred/private/wx/win32/font.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require racket/class + racket/draw/private/local + racket/draw/unsafe/pango) + +(provide + (protect-out font->hfont)) + +(define display-font-map + (pango_win32_font_map_for_display)) + +(define display-context + (pango_font_map_create_context display-font-map)) + +(define font-cache (pango_win32_font_cache_new)) + +(define (font->hfont f) + (let* ([pfont (pango_font_map_load_font display-font-map + display-context + (send f get-pango))] + [logfont (pango_win32_font_logfont pfont)]) + (begin0 + (pango_win32_font_cache_load font-cache logfont) + (g_free logfont)))) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt new file mode 100644 index 00000000..5ebf30e6 --- /dev/null +++ b/collects/mred/private/wx/win32/frame.rkt @@ -0,0 +1,516 @@ +#lang racket/base +(require racket/class + racket/draw + (only-in racket/list last) + ffi/unsafe + ffi/unsafe/alloc + "../../syntax.rkt" + "../../lock.rkt" + "../common/queue.rkt" + "../common/freeze.rkt" + "utils.rkt" + "const.rkt" + "types.rkt" + "theme.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "cursor.rkt") + +(provide + (protect-out frame% + display-size + display-origin)) + +(define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) +(define-user32 GetActiveWindow (_wfun -> _HWND)) +(define-user32 SetFocus (_wfun _HWND -> _HWND)) +(define-user32 BringWindowToTop (_wfun _HWND -> (r : _BOOL) -> (unless r (failed 'BringWindowToTop)))) + +(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) + +(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DrawMenuBar)))) + +(define-user32 IsZoomed (_wfun _HWND -> _BOOL)) + +(define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL) + -> (unless r (failed 'SystemParametersInfo)))) +(define-cstruct _MINMAXINFO ([ptReserved _POINT] + [ptMaxSize _POINT] + [ptMaxPosition _POINT] + [ptMinTrackSize _POINT] + [ptMaxTrackSize _POINT])) + +(define-cstruct _ICONINFO ([fIcon _BOOL] + [xHotspot _DWORD] + [yHotspot _DWORD] + [hbmMask _HBITMAP] + [hbmColor _HBITMAP])) + +(define-user32 DestroyIcon (_wfun _HICON -> (r : _BOOL) + -> (unless r (failed 'DestroyIcon))) + #:wrap (deallocator)) +(define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON) + -> (or r (failed 'CreateIconIndirect))) + #:wrap (allocator DestroyIcon)) + +(define SPI_GETWORKAREA #x0030) + +(define (display-size xb yb ?) + (atomically + (let ([hdc (GetDC #f)]) + (set-box! xb (GetDeviceCaps hdc HORZRES)) + (set-box! yb (GetDeviceCaps hdc VERTRES)) + (ReleaseDC #f hdc)))) + +(define (display-origin xb yb avoid-bars?) + (if avoid-bars? + (let ([r (make-RECT 0 0 0 0)]) + (SystemParametersInfoW SPI_GETWORKAREA 0 r 0) + (set-box! xb (RECT-left r)) + (set-box! yb (RECT-top r))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + +(define mouse-frame #f) + +(define WS_EX_TOOLWINDOW #x00000080) +(define WS_EX_TOPMOST #x00000008) +(define WS_EX_WINDOWEDGE #x00000100) +(define WS_EX_PALETTEWINDOW (bitwise-ior WS_EX_WINDOWEDGE + WS_EX_TOOLWINDOW + WS_EX_TOPMOST)) + +(define-cstruct _WINDOWPLACEMENT + ([length _UINT] + [flags _UINT] + [showCmd _UINT] + [ptMinPosition _POINT] + [ptMaxPosition _POINT] + [rcNormalPosition _RECT])) + +(define-user32 GetWindowPlacement (_wfun _HWND _WINDOWPLACEMENT-pointer -> (r : _BOOL) + -> (unless r (failed 'GetWindowPlacement)))) + +(define-user32 IsIconic (_fun _HWND -> _BOOL)) + +(defclass frame% window% + (init parent + label + x y w h + style) + + (inherit get-hwnd + is-shown? + get-eventspace + on-size + pre-on-char pre-on-event + reset-cursor-in-child) + + (define/public (create-frame parent label x y w h style) + (CreateWindowExW (if (memq 'float style) + (bitwise-ior WS_EX_TOOLWINDOW + (if (memq 'no-caption style) + WS_EX_TOPMOST + WS_EX_PALETTEWINDOW)) + 0) + "PLTFrame" + (if label label "") + (bitwise-ior + WS_POPUP + (if (memq 'no-resize-border style) + 0 + (bitwise-ior WS_THICKFRAME + WS_BORDER + WS_MAXIMIZEBOX)) + (if (memq 'no-system-menu style) + 0 + WS_SYSMENU) + (if (memq 'no-caption style) + 0 + (bitwise-ior WS_CAPTION + WS_MINIMIZEBOX))) + (if (= x -11111) CW_USEDEFAULT x) + (if (= y -11111) CW_USEDEFAULT y) + w h + #f + #f + hInstance + #f)) + + (define saved-title (or label "")) + (define hidden-zoomed? #f) + (define float-without-caption? (and (memq 'float style) + (memq 'no-caption style))) + + (define min-width #f) + (define min-height #f) + (define max-width #f) + (define max-height #f) + + (super-new [parent #f] + [hwnd (create-frame parent label x y w h style)] + [style (cons 'deleted style)]) + + (define hwnd (get-hwnd)) + (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA) + + ;; record delta between size and client size + ;; for getting the client size when the frame + ;; is iconized: + (define-values (client-dw client-dh) + (let ([w (box 0)] [h (box 0)] + [cw (box 0)] [ch (box 0)]) + (get-size w h) + (get-client-size cw ch) + (values (- (unbox w) (unbox cw)) + (- (unbox h) (unbox ch))))) + + (define/public (is-dialog?) #f) + + (define/override (show on?) + (let ([es (get-eventspace)]) + (when (and on? + (eventspace-shutdown? es)) + (error (string->symbol + (format "show method in ~a" + (if (is-dialog?) + 'dialog% + 'frame%))) + "eventspace has been shutdown"))) + (super show on?)) + + (define/override (direct-show on?) + ;; atomic mode + (when (eq? mouse-frame this) (set! mouse-frame #f)) + (register-frame-shown this on?) + (when (and (not on?) (is-shown?)) + (set! hidden-zoomed? (is-maximized?))) + (super direct-show on? (if hidden-zoomed? + SW_SHOWMAXIMIZED + (if float-without-caption? + SW_SHOWNOACTIVATE + SW_SHOW))) + (when (and on? (iconized?)) + (ShowWindow hwnd SW_RESTORE)) + (when on? + (unless float-without-caption? + (BringWindowToTop hwnd)))) + + (define/public (destroy) + (direct-show #f)) + + (define/private (stdret f d) + (if (is-dialog?) d f)) + + (define/override (wndproc w msg wParam lParam default) + (cond + [(= msg WM_CLOSE) + (queue-window-event this (lambda () + (when (on-close) + (direct-show #f)))) + 0] + [(and (= msg WM_SIZE) + (not (= wParam SIZE_MINIMIZED))) + (queue-window-event this (lambda () (on-size 0 0))) + (stdret 0 1)] + [(= msg WM_MOVE) + (queue-window-event this (lambda () (on-size 0 0))) + (stdret 0 1)] + [(= msg WM_ACTIVATE) + (let ([state (LOWORD wParam)] + [minimized (HIWORD wParam)]) + (unless (not (zero? minimized)) + (let ([on? (or (= state WA_ACTIVE) + (= state WA_CLICKACTIVE))]) + (when on? (set-frame-focus)) + (queue-window-event this (lambda () (on-activate on?)))))) + 0] + [(and (= msg WM_COMMAND) + (zero? (HIWORD wParam))) + (queue-window-event this (lambda () (on-menu-command (LOWORD wParam)))) + 0] + [(= msg WM_INITMENU) + (constrained-reply (get-eventspace) + (lambda () (on-menu-click)) + (void)) + 0] + [(= msg WM_GETMINMAXINFO) + (let ([mmi (cast lParam _LPARAM _MINMAXINFO-pointer)]) + (when (or max-width max-height) + (set-MINMAXINFO-ptMaxTrackSize! + mmi + (make-POINT (or max-width + (POINT-x (MINMAXINFO-ptMaxTrackSize mmi))) + (or max-height + (POINT-y (MINMAXINFO-ptMaxTrackSize mmi)))))) + (when (or min-width min-height) + (set-MINMAXINFO-ptMinTrackSize! + mmi + (make-POINT (or min-width + (POINT-x (MINMAXINFO-ptMinTrackSize mmi))) + (or min-height + (POINT-y (MINMAXINFO-ptMinTrackSize mmi))))))) + 0] + [else (super wndproc w msg wParam lParam default)])) + + (define/override (set-size x y w h) + (unless (and (= w -1) (= h -1)) + (maximize #f)) + (super set-size x y w h)) + + (define/public (on-close) #t) + + (define/override (is-shown-to-root?) + (is-shown?)) + (define/override (is-enabled-to-root?) + #t) + + (define/public (on-toolbar-click) (void)) + (define/public (on-menu-click) (void)) + + (define/public (on-menu-command i) (void)) + + (def/public-unimplemented on-mdi-activate) + + (define/public (enforce-size min-x min-y max-x max-y step-x step-y) + (set! min-width (max 1 min-x)) + (set! min-height (max 1 min-y)) + (set! max-width (and (positive? max-x) max-x)) + (set! max-height (and (positive? max-y) max-y))) + + (define focus-window-path #f) + (define/override (not-focus-child v) + (when (and focus-window-path + (memq v focus-window-path)) + (set! focus-window-path #f))) + (define/override (set-top-focus win win-path child-hwnd) + (set! focus-window-path win-path) + (when (ptr-equal? hwnd (GetActiveWindow)) + (SetFocus child-hwnd))) + + (define/private (set-frame-focus) + (when (pair? focus-window-path) + (SetFocus (send (last focus-window-path) get-focus-hwnd)))) + + (define/override (can-accept-focus?) + #f) + (define/override (child-can-accept-focus?) + #t) + + (define/public (on-activate on?) (void)) + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (define/override (generate-parent-mouse-ins mk) + ;; assert: in-window is always the panel child + (unless (eq? mouse-frame this) + (when mouse-frame + (let ([win mouse-frame]) + (set! mouse-frame #f) + (send win send-leaves mk))) + (set! mouse-frame this)) + #f) + + (define/override (send-child-leaves mk) + (if (eq? mouse-frame this) + (if saved-child + (send saved-child send-leaves mk) + #f) + #f)) + + (define/override (reset-cursor default) + (if wait-cursor-on? + (void (SetCursor (get-wait-cursor))) + (when saved-child + (reset-cursor-in-child saved-child default)))) + + (define/override (get-dialog-level) 0) + + (define/public (frame-relative-dialog-status win) + #f) + + (define wait-cursor-on? #f) + (define/public (set-wait-cursor-mode on?) + (set! wait-cursor-on? on?) + (when (eq? mouse-frame this) + (if on? + (void (SetCursor (get-wait-cursor))) + (reset-cursor (get-arrow-cursor))))) + (define/public (is-wait-cursor-on?) + wait-cursor-on?) + + (define/override (center mode wrt) + (let ([sw (box 0)] + [sh (box 0)] + [w (box 0)] + [h (box 0)] + [x (box 0)] + [y (box 0)]) + (display-size sw sh #f) + (get-size w h) + (MoveWindow hwnd + (if (or (eq? mode 'both) + (eq? mode 'horizontal)) + (quotient (- (unbox sw) (unbox w)) 2) + (get-x)) + (if (or (eq? mode 'both) + (eq? mode 'vertical)) + (quotient (- (unbox sh) (unbox h)) 2) + (get-x)) + (unbox w) + (unbox h) + #t))) + + (define saved-child #f) + (define/override (register-child child on?) + (unless on? (error 'register-child-in-frame "did not expect #f")) + (unless (or (not saved-child) (eq? child saved-child)) + (error 'register-child-in-frame "expected only one child")) + (set! saved-child child) + (send child set-arrow-cursor)) + (define/override (register-child-in-parent on?) + (void)) + + (define/override (get-top-frame) this) + + (define/public (designate-root-frame) (void)) + (def/public-unimplemented system-menu) + + (define modified? #f) + (define/public (set-modified on?) + (unless (eq? modified? (and on? #t)) + (set! modified? (and on? #t)) + (set-title saved-title))) + + (define/public (is-maximized?) + (if (is-shown?) + hidden-zoomed? + (IsZoomed hwnd))) + + (define/public (maximize on?) + (if (is-shown?) + (ShowWindow hwnd (if on? + SW_MAXIMIZE + SW_RESTORE)) + (set! hidden-zoomed? (and on? #t)))) + + (define/public (iconized?) + (IsIconic hwnd)) + + (define/public (iconize on?) + (when (is-shown?) + (unless (eq? (and on? #t) (iconized?)) + (ShowWindow hwnd (if on? SW_MINIMIZE SW_RESTORE))))) + + (define/private (get-placement) + (let ([wp (make-WINDOWPLACEMENT + (ctype-sizeof _WINDOWPLACEMENT) + 0 + 0 + (make-POINT 0 0) + (make-POINT 0 0) + (make-RECT 0 0 0 0))]) + (GetWindowPlacement hwnd wp) + wp)) + + (define/override (get-size w h) + (if (iconized?) + (let ([wp (get-placement)]) + (let ([r (WINDOWPLACEMENT-rcNormalPosition wp)]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + (super get-size w h))) + + (define/override (get-client-size w h) + (if (iconized?) + (begin + (get-size w h) + (set-box! w (max 1 (- (unbox w) client-dw))) + (set-box! h (max 1 (- (unbox h) client-dh)))) + (super get-client-size w h))) + + (define/override (get-x) + (if (iconized?) + (let ([wp (get-placement)]) + (RECT-left (WINDOWPLACEMENT-rcNormalPosition wp))) + (RECT-left (GetWindowRect hwnd)))) + + (define/override (get-y) + (if (iconized?) + (let ([wp (get-placement)]) + (RECT-top (WINDOWPLACEMENT-rcNormalPosition wp))) + (RECT-top (GetWindowRect hwnd)))) + + (define/override (get-width) + (if (iconized?) + (let ([w (box 0)]) + (get-size w (box 0)) + (unbox w)) + (super get-width))) + + (define/override (get-height) + (if (iconized?) + (let ([h (box 0)]) + (get-size (box 0) h) + (unbox h)) + (super get-height))) + + (def/public-unimplemented get-menu-bar) + + (define menu-bar #f) + (define/public (set-menu-bar mb) + (atomically + (set! menu-bar mb) + (send mb set-parent this))) + + (define/public (draw-menu-bar) + (DrawMenuBar hwnd)) + + (define/override (is-frame?) #t) + + ;; Retain to aviod GC of the icon: + (define small-hicon #f) + (define big-hicon #f) + + (define/public (set-icon bm mask [mode 'both]) + (let* ([bg-hbitmap + (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] + [dc (make-object bitmap-dc% bm)]) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send dc set-bitmap #f) + (bitmap->hbitmap bm #:b&w? #t))] + [main-hbitmap (bitmap->hbitmap bm #:mask mask)] + [hicon (CreateIconIndirect + (make-ICONINFO + #t 0 0 + bg-hbitmap + main-hbitmap))]) + (DeleteObject bg-hbitmap) + (DeleteObject main-hbitmap) + (when (or (eq? mode 'small) + (eq? mode 'both)) + (atomically + (set! small-hicon hicon) + (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM)))) + (when (or (eq? mode 'big) + (eq? mode 'both)) + (atomically + (set! big-hicon hicon) + (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))) + + (define/public (set-title s) + (atomically + (set! saved-title s) + (SetWindowTextW (get-hwnd) (string-append s (if modified? "*" ""))))) + + (define/public (popup-menu-with-char c) + (DefWindowProcW hwnd WM_SYSKEYDOWN (char->integer c) (arithmetic-shift 1 29)) + (DefWindowProcW hwnd WM_SYSCHAR (char->integer c) (arithmetic-shift 1 29)))) + diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt new file mode 100644 index 00000000..6c92bd59 --- /dev/null +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -0,0 +1,65 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") + +(provide + (protect-out gauge%)) + +(define PBS_VERTICAL #x04) +(define PBM_SETRANGE (+ WM_USER 1)) +(define PBM_SETPOS (+ WM_USER 2)) +(define PBM_GETRANGE (+ WM_USER 7));wParam = return (TRUE ? low : high). lParam = PPBRANGE or NULL +(define PBM_GETPOS (+ WM_USER 8)) + +(define gauge% + (class item% + (inherit set-size) + + (init parent + label + rng + x y w h + style + font) + + (define hwnd + (CreateWindowExW/control 0 + "PLTmsctls_progress32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if (memq 'vertical style) + PBS_VERTICAL + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (super-new [callback void] + [parent parent] + [hwnd hwnd] + [style style]) + + (set-range rng) + + (if (memq 'horizontal style) + (set-size -11111 -11111 100 24) + (set-size -11111 -11111 24 100)) + + (define/public (get-value) + (SendMessageW hwnd PBM_GETPOS 0 0)) + (define/public (set-value v) + (void (SendMessageW hwnd PBM_SETPOS v 0))) + (define/public (get-range) + (SendMessageW hwnd PBM_GETRANGE 0 0)) + (define/public (set-range v) + (void (SendMessageW hwnd PBM_SETRANGE 0 (MAKELPARAM 0 v)))))) diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt new file mode 100644 index 00000000..3bb5a83e --- /dev/null +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt") + +(provide + (protect-out scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-dc + make-gc-show-desc + make-gc-hide-desc)) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define-gdi32 BitBlt/raw _fpointer + #; + (_wfun _HDC _int _int _int _int _HDC _int _int _DWORD -> _BOOL) + #:c-id BitBlt) +(define-gdi32 SelectObject/raw _fpointer + #:c-id SelectObject) + +(define SRCCOPY #x00CC0020) + +(define blit-hdc (CreateCompatibleDC #f)) + +(define (create-gc-dc hwnd) + (GetDC hwnd)) + +(define (make-draw hdc hbitmap x y w h) + (vector + (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) + (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void + BitBlt/raw hdc x y w h blit-hdc 0 0 SRCCOPY) + (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f))) + +(define (make-gc-show-desc hdc hbitmap x y w h) + (make-draw hdc hbitmap x y w h)) + +(define (make-gc-hide-desc hdc hbitmap x y w h) + (make-draw hdc hbitmap x y w h)) diff --git a/collects/mred/private/wx/win32/gl-context.rkt b/collects/mred/private/wx/win32/gl-context.rkt new file mode 100644 index 00000000..bd94aeb8 --- /dev/null +++ b/collects/mred/private/wx/win32/gl-context.rkt @@ -0,0 +1,140 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + racket/draw/private/gl-config + (prefix-in draw: racket/draw/private/gl-context) + "types.rkt" + "utils.rkt") + +(provide + (protect-out create-gl-context)) + +(define opengl32-lib (ffi-lib "opengl32.dll")) + +(define-ffi-definer define-opengl32 opengl32-lib) + +(define _HGLRC (_cpointer/null 'HGLRC)) + +(define-cstruct _PIXELFORMATDESCRIPTOR + ([nSize _WORD] + [nVersion _WORD] + [dwFlags _DWORD] + [iPixelType _BYTE] + [cColorBits _BYTE] + [cRedBits _BYTE] + [cRedShift _BYTE] + [cGreenBits _BYTE] + [cGreenShift _BYTE] + [cBlueBits _BYTE] + [cBlueShift _BYTE] + [cAlphaBits _BYTE] + [cAlphaShift _BYTE] + [cAccumBits _BYTE] + [cAccumRedBits _BYTE] + [cAccumGreenBits _BYTE] + [cAccumBlueBits _BYTE] + [cAccumAlphaBits _BYTE] + [cDepthBits _BYTE] + [cStencilBits _BYTE] + [cAuxBuffers _BYTE] + [iLayerType _BYTE] + [bReserved _BYTE] + [dwLayerMask _DWORD] + [dwVisibleMask _DWORD] + [dwDamageMask _DWORD])) + +(define-gdi32 ChoosePixelFormat (_wfun _HDC _PIXELFORMATDESCRIPTOR-pointer -> _int)) +(define-gdi32 SetPixelFormat (_wfun _HDC _int _PIXELFORMATDESCRIPTOR-pointer -> _BOOL)) +(define-gdi32 DescribePixelFormat (_wfun _HDC _int _UINT _PIXELFORMATDESCRIPTOR-pointer -> (r : _int) + -> (if (zero? r) + (failed 'DescribePixelFormat) + r))) +(define-gdi32 SwapBuffers (_wfun _HDC -> _BOOL)) + +(define-opengl32 wglDeleteContext (_wfun _HGLRC -> (r : _BOOL) + -> (unless r (failed 'wglDeleteContext))) + #:wrap (deallocator)) +(define-opengl32 wglCreateContext (_wfun _HDC -> _HGLRC) + #:wrap (allocator wglDeleteContext)) + +(define-opengl32 wglMakeCurrent (_wfun _HDC _HGLRC -> _BOOL)) + +;; ---------------------------------------- + +(define gl-context% + (class draw:gl-context% + (init-field [hglrc hglrc] + [hdc hdc]) + + (define/override (draw:do-call-as-current t) + (dynamic-wind + (lambda () + (wglMakeCurrent hdc hglrc)) + t + (lambda () + (wglMakeCurrent #f #f)))) + + (define/override (draw:do-swap-buffers) + (SwapBuffers hdc)) + + (super-new))) + +;; ---------------------------------------- + +(define PFD_DOUBLEBUFFER #x00000001) +(define PFD_STEREO #x00000002) +(define PFD_DRAW_TO_WINDOW #x00000004) +(define PFD_DRAW_TO_BITMAP #x00000008) +(define PFD_SUPPORT_GDI #x00000010) +(define PFD_SUPPORT_OPENGL #x00000020) +(define PFD_NEED_PALETTE #x00000080) +(define PFD_NEED_SYSTEM_PALETTE #x00000100) +(define PFD_GENERIC_ACCELERATED #x00001000) +(define PFD_TYPE_RGBA 0) +(define PFD_MAIN_PLANE 0) + +(define (create-gl-context hdc config offscreen?) + (let* ([config (or config (new gl-config%))] + [accum (send config get-accum-size)] + [pfd + (make-PIXELFORMATDESCRIPTOR + (ctype-sizeof _PIXELFORMATDESCRIPTOR) + 1 ; version + (bitwise-ior + PFD_SUPPORT_OPENGL + (if (send config get-stereo) PFD_STEREO 0) + (if (and (not offscreen?) + (send config get-double-buffered)) + PFD_DOUBLEBUFFER + 0) + (if offscreen? + (bitwise-ior PFD_DRAW_TO_BITMAP + PFD_SUPPORT_GDI) + (bitwise-ior PFD_DRAW_TO_WINDOW))) + PFD_TYPE_RGBA ; color type + (if offscreen? 32 24) ; prefered color depth + 0 0 0 0 0 0 ; color bits (ignored) + 0 ; no alpha buffer + 0 ; alpha bits (ignored) + (* 4 accum) ; no accumulation buffer + accum accum accum accum ; accum bits + (if offscreen? 32 (send config get-depth-size)) ; depth buffer + (send config get-stencil-size) ; stencil buffer + 0 ; no auxiliary buffers + PFD_MAIN_PLANE ; main layer + 0 ; reserved + 0 0 0 ; no layer, visible, damage masks + )] + [pixelFormat (ChoosePixelFormat hdc pfd)]) + (and (not (zero? pixelFormat)) + (SetPixelFormat hdc pixelFormat pfd) + (begin + (DescribePixelFormat hdc pixelFormat (ctype-sizeof _PIXELFORMATDESCRIPTOR) pfd) + (when (not (zero? (bitwise-and (PIXELFORMATDESCRIPTOR-dwFlags pfd) + PFD_NEED_PALETTE))) + (log-error "don't know how to create a GL palette, yet")) + (let ([hglrc (wglCreateContext hdc)]) + (and hglrc + (new gl-context% [hglrc hglrc] [hdc hdc]))))))) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt new file mode 100644 index 00000000..49398675 --- /dev/null +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -0,0 +1,72 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "panel.rkt" + "wndclass.rkt" + "types.rkt") + +(provide + (protect-out group-panel%)) + + +(define group-panel% + (class (item-mixin (panel-mixin window%)) + (init parent + x y w h + style + label) + + (inherit auto-size set-control-font) + + (define hwnd + (CreateWindowExW/control 0 + "PLTBUTTON" + (or label "") + (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define client-hwnd + (CreateWindowExW 0 + "PLTTabPanel" + #f + (bitwise-ior WS_CHILD WS_VISIBLE) + 0 0 w h + hwnd + #f + hInstance + #f)) + + (super-new [callback void] + [parent parent] + [hwnd hwnd] + [extra-hwnds (list client-hwnd)] + [style style]) + + (define/override (get-client-hwnd) + client-hwnd) + + (define label-h 0) + + (set-control-font #f) + (auto-size #f label 0 0 0 0 + (lambda (w h) + (set! label-h h) + (set-size -11111 -11111 (+ w 10) (+ h 10)))) + + (define/public (set-label lbl) + (SetWindowTextW hwnd lbl)) + + (define/override (set-size x y w h) + (super set-size x y w h) + (unless (or (= w -1) (= h -1)) + (MoveWindow client-hwnd 3 (+ label-h 3) (- w 6) (- h label-h 6) #t))))) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt new file mode 100644 index 00000000..4ca70954 --- /dev/null +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -0,0 +1,97 @@ +#lang racket/base +(require ffi/unsafe + racket/draw/unsafe/cairo + racket/draw + racket/draw/private/local + racket/class + "types.rkt" + "utils.rkt" + "const.rkt") + +(provide + (protect-out bitmap->hbitmap + hbitmap->bitmap)) + +(define (bitmap->hbitmap bm + #:mask [mask-bm #f] + #:b&w? [b&w? #f] + #:bg [bg (GetSysColor COLOR_BTNFACE)]) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [mask-bm (or mask-bm + (send bm get-loaded-mask))] + [to-frac (lambda (v) (/ v 255.0))] + [screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [hbitmap (if b&w? + (CreateBitmap w h 1 1 #f) + (CreateCompatibleBitmap screen-hdc w h))] + [old-hbitmap (SelectObject hdc hbitmap)]) + (ReleaseDC #f screen-hdc) + (let* ([s (cairo_win32_surface_create hdc)] + [cr (cairo_create s)]) + (cairo_surface_destroy s) + (cairo_set_source_rgba cr + (to-frac (GetRValue bg)) + (to-frac (GetGValue bg)) + (to-frac (GetBValue bg)) + 1.0) + (cairo_paint cr) + (let ([mask-p (and mask-bm + (cairo_pattern_create_for_surface + (send mask-bm get-cairo-alpha-surface)))]) + (let ([p (cairo_get_source cr)]) + (cairo_pattern_reference p) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (if mask-p + (cairo_mask cr mask-p) + (begin + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr))) + (when mask-p + (cairo_pattern_destroy mask-p)) + (cairo_set_source cr p) + (cairo_pattern_destroy p))) + (cairo_destroy cr) + (SelectObject hdc old-hbitmap) + (DeleteDC hdc) + hbitmap))) + +(define-cstruct _BITMAP + ([bmType _LONG] + [bmWidth _LONG] + [bmHeight _LONG] + [bmWidthBytes _LONG] + [bmPlanes _WORD] + [bmBitsPixel _WORD] + [bmBits _pointer])) + +(define-gdi32 GetObjectW (_wfun _pointer _int _pointer -> (r : _int) + -> (when (zero? r) (failed 'GetObject)))) + +(define (hbitmap->bitmap hbitmap) + (let* ([bmi (let ([b (make-BITMAP 0 0 0 0 0 0 #f)]) + (GetObjectW hbitmap (ctype-sizeof _BITMAP) b) + b)] + [w (BITMAP-bmWidth bmi)] + [h (BITMAP-bmHeight bmi)] + [screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [old-hbitmap (SelectObject hdc hbitmap)] + [bm (make-object bitmap% w h (= 1 (BITMAP-bmBitsPixel bmi)) #t)]) + (ReleaseDC #f screen-hdc) + (let* ([s (cairo_win32_surface_create hdc)] + [cr (cairo_create (send bm get-cairo-surface))]) + (let ([p (cairo_get_source cr)]) + (cairo_pattern_reference p) + (cairo_set_source_surface cr s 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr) + (cairo_set_source cr p) + (cairo_pattern_destroy p)) + (cairo_destroy cr) + (SelectObject hdc old-hbitmap) + (DeleteDC hdc) + bm))) diff --git a/collects/mred/private/wx/win32/icons.rkt b/collects/mred/private/wx/win32/icons.rkt new file mode 100644 index 00000000..6fd15f99 --- /dev/null +++ b/collects/mred/private/wx/win32/icons.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require ffi/unsafe) + +(provide IDC_ARROW IDC_CROSS + IDI_APPLICATION IDI_HAND IDI_QUESTION IDI_WINLOGO) + +(define (MAKEINTRESOURCE n) (ptr-add #f n)) +(define IDC_ARROW (MAKEINTRESOURCE 32512)) +(define IDC_CROSS (MAKEINTRESOURCE 32515)) +(define IDI_APPLICATION (MAKEINTRESOURCE 32512)) +(define IDI_HAND (MAKEINTRESOURCE 32513)) +(define IDI_QUESTION (MAKEINTRESOURCE 32514)) +(define IDI_WINLOGO (MAKEINTRESOURCE 32517)) diff --git a/collects/mred/private/wx/win32/init.rkt b/collects/mred/private/wx/win32/init.rkt new file mode 100644 index 00000000..f0c23c10 --- /dev/null +++ b/collects/mred/private/wx/win32/init.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +;; Registers the window class: +(require "wndclass.rkt" + "queue.rkt") + +(define pump-thread (win32-start-event-pump)) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt new file mode 100644 index 00000000..bc549375 --- /dev/null +++ b/collects/mred/private/wx/win32/item.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") + +(provide + (protect-out item-mixin + item%)) + +(define (item-mixin %) + (class % + (inherit on-set-focus + on-kill-focus + try-mouse + wndproc) + + (init-field [callback void]) + (define/public (command e) + (callback this e)) + + (super-new) + + (define/public (ctlproc w msg wParam lParam default) + (if (try-mouse w msg wParam lParam) + 0 + (cond + [(= msg WM_SETFOCUS) + (queue-window-event this (lambda () (on-set-focus))) + (default w msg wParam lParam)] + [(= msg WM_KILLFOCUS) + (queue-window-event this (lambda () (on-kill-focus))) + (default w msg wParam lParam)] + [else + (wndproc-for-ctlproc w msg wParam lParam default)]))) + + (define/public (wndproc-for-ctlproc w msg wParam lParam default) + (wndproc w msg wParam lParam default)))) + +(define item% + (class (item-mixin window%) + (inherit get-hwnd) + + (super-new) + + (define/override (gets-focus?) #t) + + ;; Retain to avoid GC of the bitmaps: + (define label-hbitmap #f) + (define/public (remember-label-bitmap hbitmap) + (set! label-hbitmap hbitmap)) + + (define/public (set-label s) + (if (s . is-a? . bitmap%) + (let ([hbitmap (bitmap->hbitmap s)]) + (atomically + (set! label-hbitmap hbitmap) + (SendMessageW (get-hwnd) + (get-setimage-message) + IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) + (SetWindowTextW (get-hwnd) s))) + + (define/public (get-setimage-message) BM_SETIMAGE) + + (def/public-unimplemented get-label))) + + diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt new file mode 100644 index 00000000..fefc4603 --- /dev/null +++ b/collects/mred/private/wx/win32/key.rkt @@ -0,0 +1,258 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "../common/event.rkt") + +(provide + (protect-out make-key-event + generates-key-event? + reset-key-mapping)) + +(define-user32 GetKeyState (_wfun _int -> _SHORT)) +(define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) +(define-user32 VkKeyScanW (_wfun _WCHAR -> _SHORT)) + +(define (generates-key-event? msg) + (let ([message (MSG-message msg)]) + (and (memq message (list WM_KEYDOWN WM_SYSKEYDOWN + WM_KEYUP WM_SYSKEYUP)) + (make-key-event #t + (MSG-wParam msg) + (MSG-lParam msg) + #f + (or (= message WM_KEYUP) + (= message WM_SYSKEYUP)) + (MSG-hwnd msg))))) + +(define (THE_SCAN_CODE lParam) + (bitwise-and (arithmetic-shift lParam -16) #x1FF)) + +(define generic_ascii_code (make-hasheq)) + +;; The characters in find_shift_alts are things that we'll try +;; to include in keyboard events as char-if-Shift-weren't-pressed, +;; char-if-AltGr-weren't-pressed, etc. +(define find_shift_alts (string-append + "!@#$%^&*()_+-=\\|[]{}:\";',.<>/?~`" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789")) +(define other-key-codes #f) +(define (get-other-key-codes) + (or other-key-codes + (begin + (set! other-key-codes + (list->vector + (for/list ([i (in-string find_shift_alts)]) + (VkKeyScanW (char->integer i))))) + other-key-codes))) +(define (reset-key-mapping) + (set! other-key-codes #f)) +(define (other-orig j) + (char->integer (string-ref find_shift_alts j))) + +;; If a virtual key code has no mapping here, then the key should be +;; ignored by WM_KEYDOWN and processed by WM_CHAR instead +(define win32->symbol + (hasheq VK_CANCEL 'cancel + VK_BACK 'back + VK_TAB 'tab + VK_CLEAR 'clear + VK_RETURN 'return + VK_SHIFT 'shift + VK_CONTROL 'control + VK_MENU 'menu + VK_PAUSE 'pause + VK_SPACE 'space + VK_ESCAPE 'escape + VK_PRIOR 'prior + VK_NEXT 'next + VK_END 'end + VK_HOME 'home + VK_LEFT 'left + VK_UP 'up + VK_RIGHT 'right + VK_DOWN 'down + VK_SELECT 'select + VK_PRINT 'print + VK_EXECUTE 'execute + VK_INSERT 'insert + VK_DELETE #\rubout + VK_HELP 'help + VK_NUMPAD0 'numpad0 + VK_NUMPAD1 'numpad1 + VK_NUMPAD2 'numpad2 + VK_NUMPAD3 'numpad3 + VK_NUMPAD4 'numpad4 + VK_NUMPAD5 'numpad5 + VK_NUMPAD6 'numpad6 + VK_NUMPAD7 'numpad7 + VK_NUMPAD8 'numpad8 + VK_NUMPAD9 'numpad9 + VK_MULTIPLY 'multiply + VK_ADD 'add + VK_SUBTRACT 'subtract + VK_DECIMAL 'decimal + VK_DIVIDE 'divide + VK_F1 'f1 + VK_F2 'f2 + VK_F3 'f3 + VK_F4 'f4 + VK_F5 'f5 + VK_F6 'f6 + VK_F7 'f7 + VK_F8 'f8 + VK_F9 'f9 + VK_F10 'f10 + VK_F11 'f11 + VK_F12 'f12 + VK_F13 'f13 + VK_F14 'f14 + VK_F15 'f15 + VK_F16 'f16 + VK_F17 'f17 + VK_F18 'f18 + VK_F19 'f19 + VK_F20 'f20 + VK_F21 'f21 + VK_F22 'f22 + VK_F23 'f23 + VK_F24 'f24 + VK_NUMLOCK 'numlock + VK_SCROLL 'scroll)) + + +(define (make-key-event just-check? wParam lParam is-char? is-up? hwnd) + (let ([control-down? (not (zero? (arithmetic-shift (GetKeyState VK_CONTROL) -1)))] + [shift-down? (not (zero? (arithmetic-shift (GetKeyState VK_SHIFT) -1)))] + [caps-down? (not (zero? (arithmetic-shift (GetKeyState VK_CAPITAL) -1)))] + [alt-down? (= (bitwise-and (HIWORD lParam) KF_ALTDOWN) KF_ALTDOWN)]) + (let-values ([(id other-shift other-altgr other-shift-altgr) + (cond + [(symbol? wParam) + (values wParam #f #f #f)] + [is-char? + ;; wParam is a character or symbol + (let ([id wParam] + [sc (THE_SCAN_CODE lParam)]) + ;; Remember scan codes to help with some key-release events: + (when (byte? id) + (hash-set! generic_ascii_code id sc)) + ;; Look for elements of find_shift_alts that have a different + ;; shift/AltGr state: + (let ([k (MapVirtualKeyW sc 1)]) + (if (zero? k) + (values (integer->char id) #f #f #f) + (for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector (get-other-key-codes))] + [j (in-naturals)]) + (if (= (bitwise-and o #xFF) k) + ;; Figure out whether it's different in the shift + ;; for AltGr dimension, or both: + (if (eq? (zero? (bitwise-and o #x100)) shift-down?) + ;; different Shift + (if (eq? (= (bitwise-and o #x600) #x600) + (and control-down? alt-down?)) + ;; same AltGr + (values id (other-orig j) a sa) + ;; different AltGr + (values id s a (other-orig j))) + ;; same Shift + (if (eq? (= (bitwise-and o #x600) #x600) + (and control-down? alt-down?)) + ;; same AltGr + (values id s a sa) + ;; different AltGr + (values id s (other-orig j) sa))) + (values id s a sa))))))] + [else + ;; wParam is a virtual key code + (let ([id (hash-ref win32->symbol wParam #f)] + [override-mapping? (and control-down? (not alt-down?))] + [try-generate-release + (lambda () + (let ([sc (THE_SCAN_CODE lParam)]) + (for/fold ([id #f]) ([i (in-range 256)] #:when (not id)) + (and (equal? sc (hash-ref generic_ascii_code i #f)) + (let ([id i]) + (if (id . < . 127) + (char->integer (char-downcase (integer->char id))) + id))))))]) + (if (not id) + (if (or override-mapping? is-up?) + ;; Non-AltGr Ctl- combination, or a release event: + ;; map manually, because the default mapping is + ;; unsatisfactory + ;; Set id to the unshifted key: + (let* ([id (bitwise-and (MapVirtualKeyW wParam 2) #xFFFF)] + [id (cond + [(zero? id) #f] + [(id . < . 128) + (char->integer (char-downcase (integer->char id)))] + [else id])]) + (let-values ([(s a sa) + ;; Look for shifted alternate: + (for/fold ([s #f][a #f][sa #f]) ([o (in-vector (get-other-key-codes))] + [j (in-naturals)]) + (if (= (bitwise-and o #xFF) wParam) + (if (not (zero? (bitwise-and o #x100))) + (if (= (bitwise-and o #x600) #x600) + (values s a (other-orig j)) + (values (other-orig j) a sa)) + (if (= (bitwise-and o #x600) #x600) + (values s (other-orig j) sa) + (values s a sa))) + (values s a sa)))]) + (if (and id shift-down?) + ;; shift was pressed, so swap role of shifted and unshifted + (values s id sa a) + (values id s a sa)))) + (values (and is-up? (try-generate-release)) #f #f #f)) + (cond + [(and (not is-up?) (= wParam VK_CONTROL)) + ;; Don't generate control-key down events: + (values #f #f #f #f)] + [(and (not override-mapping?) (not is-up?) + ;; Let these get translated to WM_CHAR or skipped + ;; entirely: + (memq wParam + (list VK_ESCAPE VK_SHIFT VK_CONTROL + VK_SPACE VK_RETURN VK_TAB VK_BACK))) + (values #f #f #f #f)] + [(and (not id) is-up?) + (values (try-generate-release) #f #f #f)] + [else + (values id #f #f #f)])))])]) + (and id + (if just-check? + #t + (let* ([id (if (number? id) (integer->char id) id)] + [key-id (if (equal? id #\033) + 'escape + id)] + [e (new key-event% + [key-code (if is-up? + 'release + key-id)] + [shift-down shift-down?] + [control-down control-down?] + [meta-down alt-down?] + [alt-down #f] + [x 0] + [y 0] + [time-stamp 0] + [caps-down caps-down?])] + [as-key (lambda (v) + (if (integer? v) (integer->char v) v))]) + (when is-up? + (send e set-key-release-code key-id)) + (when other-shift + (send e set-other-shift-key-code (as-key other-shift))) + (when other-altgr + (send e set-other-altgr-key-code (as-key other-altgr))) + (when other-shift-altgr + (send e set-other-shift-altgr-key-code (as-key other-shift-altgr))) + e)))))) + diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt new file mode 100644 index 00000000..8f572f54 --- /dev/null +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -0,0 +1,199 @@ +#lang racket/base +(require racket/class + racket/draw + (only-in racket/list take drop) + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") + +(provide + (protect-out list-box%)) + +(define WS_EX_CLIENTEDGE #x00000200) + +(define LBS_NOTIFY #x0001) +(define LBS_MULTIPLESEL #x0008) +(define LBS_HASSTRINGS #x0040) +(define LBS_MULTICOLUMN #x0200) +(define LBS_WANTKEYBOARDINPUT #x0400) +(define LBS_EXTENDEDSEL #x0800) +(define LBS_DISABLENOSCROLL #x1000) + +(define LBN_SELCHANGE 1) +(define LBN_DBLCLK 2) + +(define LB_ERR -1) + +(define LB_ADDSTRING #x0180) +(define LB_RESETCONTENT #x0184) +(define LB_INSERTSTRING #x0181) +(define LB_DELETESTRING #x0182) +(define LB_GETTOPINDEX #x018E) +(define LB_SETTOPINDEX #x0197) +(define LB_GETITEMHEIGHT #x01A1) +(define LB_GETSELCOUNT #x0190) +(define LB_GETSELITEMS #x0191) +(define LB_GETCURSEL #x0188) +(define LB_SETSEL #x0185) +(define LB_SETCURSEL #x0186) +(define LB_GETSEL #x0187) +(define LB_SELITEMRANGE #x019B) + +(define list-box% + (class item% + (init parent cb + label kind x y w h + choices style + font label-font) + + (inherit set-size set-control-font + get-client-size) + + (define single? (eq? 'single kind)) + + (define hwnd + (CreateWindowExW/control WS_EX_CLIENTEDGE + "PLTLISTBOX" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + ;; Win32 sense of "multiple" and "extended" is backwards + [(eq? kind 'extended) LBS_MULTIPLESEL] + [(eq? kind 'multiple) LBS_EXTENDEDSEL] + [else 0])) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + + (super-new [callback cb] + [parent parent] + [hwnd hwnd] + [style style]) + + (set-control-font font) + (set-size -11111 -11111 40 60) + + (define callback cb) + + (define/override (is-command? cmd) + (or (= cmd LBN_SELCHANGE) + (= cmd LBN_DBLCLK))) + + (define/public (do-command cmd control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type (if (= cmd LBN_SELCHANGE) + 'list-box + 'list-box-dclick)] + [time-stamp (current-milliseconds)]))))) + + + (define num (length choices)) + (define/public (number) num) + + (define data (map (lambda (x) (box #f)) choices)) + (define/public (get-data i) (unbox (list-ref data i))) + (define/public (set-data i v) (set-box! (list-ref data i) v)) + + (define/public (set-string i str) + (atomically + (SendMessageW/str hwnd LB_INSERTSTRING i str) + (SendMessageW hwnd LB_DELETESTRING (add1 i) 0) + (void))) + + (define/public (set-first-visible-item i) + (void (SendMessageW hwnd LB_SETTOPINDEX i 0))) + + (define/public (get-first-item) + (SendMessageW hwnd LB_GETTOPINDEX 0 0)) + + (define/public (number-of-visible-items) + (let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)]) + (let ([w (box 0)] + [h (box 0)]) + (get-client-size w h) + (quotient (unbox h) ih)))) + + (define/public (clear) + (atomically + (set! data null) + (set! num 0) + (void (SendMessageW hwnd LB_RESETCONTENT 0 0)))) + + (define/public (set choices) + (atomically + (ShowWindow hwnd SW_HIDE) + (clear) + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + (set! data (map (lambda (s) (box #f)) choices)) + (set! num (length choices)) + (ShowWindow hwnd SW_SHOW))) + + (public [append* append]) + (define (append* s [v #f]) + (atomically + (SendMessageW/str hwnd LB_ADDSTRING 0 s) + (set! num (add1 num)) + (set! data (append data (list (box v)))))) + + (define/public (delete i) + (atomically + (set! data (append (take data i) (drop data (add1 i)))) + (set! num (sub1 num)) + (void (SendMessageW hwnd LB_DELETESTRING i 0)))) + + (define/public (get-selections) + (atomically + (if single? + (let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)]) + (if (= v LB_ERR) + null + (list v))) + (let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)]) + (if (zero? n) + null + (let ([selections (malloc n _LONG 'raw)]) + (SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM)) + (begin0 + (for/list ([i (in-range n)]) + (ptr-ref selections _LONG i)) + (free selections)))))))) + + (define/public (get-selection) + (let ([l (get-selections)]) + (if (null? l) + -1 + (car l)))) + + (define/public (selected? i) + (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) + + (define/public (select i [on? #t] [one? #t]) + (void + (if single? + (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) + (begin + (unless one? + (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) + (SendMessageW hwnd LB_SETSEL (if on? 1 0) i))))) + + (define/public (set-selection i) + (void (select i #t #f))) + + (def/public-unimplemented get-label-font))) diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt new file mode 100644 index 00000000..089b8301 --- /dev/null +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -0,0 +1,65 @@ +#lang racket/base +(require racket/class + (only-in racket/list take drop) + ffi/unsafe + "../../lock.rkt" + "../../syntax.rkt" + "utils.rkt" + "types.rkt" + "const.rkt") + +(provide + (protect-out menu-bar%)) + +(define-user32 CreateMenu (_wfun -> _HMENU)) +(define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL) + -> (unless r (failed 'SetMenu)))) +(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DrawMenuBar)))) + +(define menu-bar% + (class object% + (super-new) + + (define hmenu (CreateMenu)) + + (define menus null) + (define parent #f) + + (define/public (set-label-top pos str) + (send (list-ref menus pos) set-menu-label hmenu pos str) + (refresh)) + + (define/public (number) (length menus)) + + (define/public (enable-top pos on?) + (send (list-ref menus pos) enable-self hmenu pos on?) + (refresh)) + + (define/public (delete which pos) + (atomically + (set! menus (append (take menus pos) + (drop menus (add1 pos)))) + (RemoveMenu hmenu pos MF_BYPOSITION) + (refresh))) + + (define/private (refresh) + (when parent + (send parent draw-menu-bar))) + + (public [append-item append]) + (define (append-item m lbl) + (let ([l (append menus (list m))]) + (atomically + (set! menus l) + (send m set-parent this lbl hmenu))) + (refresh)) + + (define/public (popup-menu-with-char c) + (when parent + (send parent popup-menu-with-char c))) + + (define/public (set-parent f) + (SetMenu (send f get-hwnd) hmenu) + (set! parent f) + (send parent draw-menu-bar)))) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt new file mode 100644 index 00000000..ad2863fc --- /dev/null +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -0,0 +1,73 @@ +#lang racket/base +(require ffi/unsafe + scheme/class + "utils.rkt" + "types.rkt" + "const.rkt" + "../../lock.rkt" + "../../syntax.rkt") + +(provide + (protect-out menu-item% + id-to-menu-item)) + +;; Menu itens are identified by 16-bit numbers, so we have +;; to keep a hash mapping them to menu items. +(define ids (make-hash)) + +(define (id-to-menu-item id) + (let ([wb (atomically (hash-ref ids id #f))]) + (and wb (weak-box-value wb)))) + +(defclass menu-item% object% + + (define id + (let loop () + (let ([id (add1 (random #x7FFE))]) + (let ([wb (atomically (hash-ref ids id #f))]) + (if (and wb + (weak-box-value wb)) + (loop) + (begin + (atomically (hash-set! ids id (make-weak-box this))) + id)))))) + + (define parent #f) + (define label #f) + (define checkable? #f) + (define submenu #f) + + (define/public (set-parent p lbl chkbl? subm) + (set! parent p) + (set! label lbl) + (set! checkable? chkbl?) + (set! submenu subm) + id) + + (define/public (set-label hmenu pos str) + (if submenu + (ModifyMenuW hmenu pos + (bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP) + (cast (send submenu get-hmenu) _HMENU _UINT_PTR) + str) + (ModifyMenuW hmenu pos + (bitwise-ior MF_BYPOSITION MF_STRING + (GetMenuState hmenu pos MF_BYPOSITION)) + id + str))) + + (define/public (set-check hmenu pos on?) + (void + (CheckMenuItem hmenu pos (bitwise-ior MF_BYPOSITION + (if on? + MF_CHECKED + MF_UNCHECKED))))) + + (define/public (get-check hmenu pos) + (let ([s (GetMenuState hmenu pos MF_BYPOSITION)]) + (not (zero? (bitwise-and s MF_CHECKED))))) + + (public [get-id id]) + (define (get-id) id) + + (super-new)) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt new file mode 100644 index 00000000..c14d1632 --- /dev/null +++ b/collects/mred/private/wx/win32/menu.rkt @@ -0,0 +1,165 @@ +#lang racket/base +(require racket/class + ffi/unsafe + (only-in racket/list drop take) + "../../lock.rkt" + "../../syntax.rkt" + "../common/event.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "menu-item.rkt") + +(provide + (protect-out menu%)) + +(define-user32 CreatePopupMenu (_wfun -> _HMENU)) +(define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL) + -> (unless r (failed 'AppendMenuW)))) +(define-user32 EnableMenuItem (_wfun _HMENU _UINT _UINT -> _BOOL)) + +(define-user32 TrackPopupMenu(_wfun _HMENU _UINT _int _int _int _HWND (_or-null _RECT-pointer) + -> _int)) + +(define TPM_LEFTBUTTON #x0000) +(define TPM_RIGHTBUTTON #x0002) +(define TPM_NONOTIFY #x0080) +(define TPM_RETURNCMD #x0100) + +(defclass menu% object% + (init lbl + cb + font) + + (define label lbl) + (define parent #f) + (define items null) + + (define callback cb) + + (define hmenu (CreatePopupMenu)) + + (define/public (get-hmenu) hmenu) + + (define/public (set-parent p lbl parent-hmenu) + (set! label lbl) + (set! parent p) + (AppendMenuW parent-hmenu + (bitwise-ior MF_POPUP MF_STRING) + hmenu + lbl)) + + (define/public (select mb) + (when parent + (let ([m (regexp-match #rx"&[^&]" label)]) + (when m + (send parent popup-menu-with-char (string-ref (car m) 1)))))) + + (def/public-unimplemented get-font) + (def/public-unimplemented set-width) + (def/public-unimplemented set-title) + + (define/public (popup gx gy hwnd call-callback) + (let ([cmd (TrackPopupMenu hmenu + (bitwise-ior + TPM_LEFTBUTTON + TPM_RIGHTBUTTON + TPM_NONOTIFY + TPM_RETURNCMD) + gx gy + 0 hwnd #f)]) + (let* ([e (new popup-event% [event-type 'menu-popdown])]) + (unless (zero? cmd) + (send e set-menu-id cmd)) + (call-callback (lambda () (callback this e)))))) + + (define/private (with-item id proc) + (let loop ([items items] [pos 0]) + (cond + [(null? items) (void)] + [(and (car items) + (eq? id (send (car items) id))) + (proc (car items) pos)] + [else (loop (cdr items) (add1 pos))]))) + + (define/public (set-menu-label bar-hmenu pos str) + (ModifyMenuW bar-hmenu pos + (bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP) + (cast hmenu _HMENU _UINT_PTR) + str)) + + (define/public (set-label id str) + (with-item + id + (lambda (i pos) + (send i set-label hmenu pos str)))) + + (define/public (set-help-string id str) + (void)) + + (define/public (number) (length items)) + + (define/public (enable id on?) + (with-item + id + (lambda (i pos) + (void + (EnableMenuItem hmenu pos + (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED))))))) + + (define/public (enable-self parent-hmenu pos on?) + (EnableMenuItem parent-hmenu pos + (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED)))) + + (define/public (check id on?) + (with-item + id + (lambda (i pos) + (send i set-check hmenu pos on?)))) + + (define/public (checked? id) + (with-item + id + (lambda (i pos) + (send i get-check hmenu pos)))) + + (define/private (remove-item! pos) + (set! items + (append (take items pos) + (drop items (add1 pos))))) + + (define/public (delete-by-position pos) + (atomically + (remove-item! pos) + (RemoveMenu hmenu pos MF_BYPOSITION))) + + (define/public (delete id) + (with-item + id + (lambda (i pos) + (atomically + (remove-item! pos) + (RemoveMenu hmenu pos MF_BYPOSITION))))) + + (public [append-item append]) + (define (append-item id label help-str-or-submenu chckable?) + (let ([i (id-to-menu-item id)]) + (when i + (let* ([submenu (and (help-str-or-submenu . is-a? . menu%) + help-str-or-submenu)] + [id (send i set-parent this label chckable? + submenu)]) + (atomically + (set! items (append items (list i))) + (if submenu + (AppendMenuW hmenu (bitwise-ior MF_POPUP MF_STRING) (send submenu get-hmenu) label) + (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _intptr _pointer) label))))))) + + (define/public (append-separator) + (atomically + (set! items (append items (list #f))) + (AppendMenuW hmenu MF_SEPARATOR #f #f))) + + (super-new)) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt new file mode 100644 index 00000000..a140cbea --- /dev/null +++ b/collects/mred/private/wx/win32/message.rkt @@ -0,0 +1,122 @@ +#lang racket/base +(require racket/class + racket/draw + racket/promise + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") + +(provide + (protect-out message%)) + +(define STM_SETIMAGE #x0172) + +(define SS_LEFT #x00000000) +(define SS_BITMAP #x0000000E) +(define SS_ICON #x00000003) + +(define IDI_APPLICATION 32512) +(define IDI_HAND 32513) +(define IDI_QUESTION 32514) +(define IDI_EXCLAMATION 32515) +(define IDI_WARNING IDI_EXCLAMATION) +(define IDI_ERROR IDI_HAND) + +(define IMAGE_ICON 1) + +(define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON)) +(define-kernel32 GetModuleFileNameW (_wfun _pointer _pointer _DWORD -> _DWORD)) + +(define-shell32 ExtractIconW (_wfun _HINSTANCE _string/utf-16 _UINT -> (r : _HICON) + -> (or r (failed 'ExtractIconW)))) + +(define ERROR_INSUFFICIENT_BUFFER 122) + +(define app-icon + (delay + (let () + (let ([path + (let loop ([size 1024]) + (let ([p (make-bytes (* (ctype-sizeof _WCHAR) 1024))]) + (let ([r (GetModuleFileNameW #f p size)]) + (cond + [(and (or (zero? r) (= r size)) + (= (GetLastError) ERROR_INSUFFICIENT_BUFFER)) + (loop (* size 2))] + [(zero? r) (failed 'GetModuleFileNameW)] + [else (cast p _gcpointer _string/utf-16)]))))]) + (if path + (ExtractIconW hInstance path 0) + (LoadIconW #f IDI_APPLICATION)))))) +(define warning-icon + (delay + (LoadIconW #f IDI_WARNING))) +(define error-icon + (delay + (LoadIconW #f IDI_ERROR))) + +(define message% + (class item% + (inherit auto-size set-size set-control-font get-hwnd + remember-label-bitmap) + + (init parent label + x y + style font) + + (define bitmap? + (and (label . is-a? . bitmap%) + (send label ok?))) + + (define/public (get-class) "PLTSTATIC") + + (super-new [callback void] + [parent parent] + [hwnd + (CreateWindowExW/control 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + SS_BITMAP + (if (symbol? label) + SS_ICON + 0))) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + (when bitmap? + (let ([hbitmap (bitmap->hbitmap label)]) + (remember-label-bitmap hbitmap) + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) + + (when (symbol? label) + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON + (cast (force (case label + [(caution) warning-icon] + [(stop) error-icon] + [else app-icon])) + _HICON _LPARAM))) + + (set-control-font font) + + (if (symbol? label) + (set-size -11111 -11111 32 32) + (auto-size font label 0 0 0 0)) + + (define/override (get-setimage-message) + STM_SETIMAGE))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt new file mode 100644 index 00000000..c87ae2ce --- /dev/null +++ b/collects/mred/private/wx/win32/panel.rkt @@ -0,0 +1,111 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "window.rkt" + "wndclass.rkt" + "utils.rkt" + "const.rkt" + "cursor.rkt") + +(provide + (protect-out panel-mixin + panel%)) + +(define (panel-mixin %) + (class % + (inherit is-enabled-to-root? + reset-cursor-in-child + get-client-hwnd) + + (super-new) + + (define children null) + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (unless on? + (when (eq? child mouse-in-child) + (set! mouse-in-child #f))) + (set! children + (if on? + (cons child children) + (remq child children))) + (send child parent-enable (is-enabled-to-root?))))) + + (define/override (internal-enable on?) + (super internal-enable on?) + (for ([c (in-list children)]) + (send c parent-enable on?))) + + (define mouse-in-child #f) + (define/override (generate-mouse-ins in-window mk) + (unless (eq? in-window this) + (unless (eq? in-window mouse-in-child) + (when mouse-in-child + (send mouse-in-child send-leaves mk)) + (set! mouse-in-child in-window))) + (super generate-mouse-ins in-window mk)) + + (define/override (reset-cursor default) + (if mouse-in-child + (reset-cursor-in-child mouse-in-child default) + (super reset-cursor default))) + + (define/override (send-leaves mk) + (when mouse-in-child + (let ([w mouse-in-child]) + (set! mouse-in-child #f) + (send w send-leaves mk))) + (super send-leaves mk)) + + (define/override (send-child-leaves mk) + (if mouse-in-child + (let ([w mouse-in-child]) + (set! mouse-in-child #f) + (send w send-leaves mk) + #t) + #f)) + + (define/override (wants-mouse-capture? control-hwnd) + (ptr-equal? (get-client-hwnd) control-hwnd)) + + (define lbl-pos 'horizontal) + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (define/public (set-item-cursor x y) (void)))) + +(define WS_EX_STATICEDGE #x00020000) + +(define panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) + + (super-new [parent parent] + [hwnd + (CreateWindowExW (if (memq 'border style) + WS_EX_STATICEDGE + 0) + (if (send parent is-frame?) + "PLTPanel" + "PLTTabPanel") + #f + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + ;; For panel in a frame, adjust default cursor to arrow: + (define arrow-cursor? #f) + (define/public (set-arrow-cursor) (set! arrow-cursor? #t)) + (define/override (generate-parent-mouse-ins mk) + (or (super generate-parent-mouse-ins mk) + (and arrow-cursor? + (get-arrow-cursor)))))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt new file mode 100644 index 00000000..d6652c53 --- /dev/null +++ b/collects/mred/private/wx/win32/platform.rkt @@ -0,0 +1,90 @@ +#lang racket/base +(require "init.rkt" + "button.rkt" + "canvas.rkt" + "check-box.rkt" + "choice.rkt" + "clipboard.rkt" + "cursor.rkt" + "dialog.rkt" + "frame.rkt" + "gauge.rkt" + "gl-context.rkt" + "group-panel.rkt" + "item.rkt" + "list-box.rkt" + "menu.rkt" + "menu-bar.rkt" + "menu-item.rkt" + "message.rkt" + "panel.rkt" + "printer-dc.rkt" + "radio-box.rkt" + "slider.rkt" + "tab-panel.rkt" + "window.rkt" + "procs.rkt") +(provide (protect-out platform-values)) + +(define (platform-values) + (values + button% + canvas% + check-box% + choice% + clipboard-driver% + cursor-driver% + dialog% + frame% + gauge% + group-panel% + item% + list-box% + menu% + menu-bar% + menu-item% + message% + panel% + printer-dc% + radio-box% + slider% + tab-panel% + window% + can-show-print-setup? + show-print-setup + id-to-menu-item + file-selector + is-color-display? + get-display-depth + has-x-selection? + hide-cursor + bell + display-size + display-origin + flush-display + fill-private-color + cancel-quit + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + get-double-click-time + run-printout + file-creator-and-type + location->window + shortcut-visible-in-label? + unregister-collecting-blit + register-collecting-blit + find-graphical-system-path + play-sound + get-panel-background + font-from-user-platform-mode + get-font-from-user + color-from-user-platform-mode + get-color-from-user + special-option-key + special-control-key + get-highlight-background-color + get-highlight-text-color + make-screen-bitmap + make-gl-bitmap + check-for-break)) diff --git a/collects/mred/private/wx/win32/printer-dc.rkt b/collects/mred/private/wx/win32/printer-dc.rkt new file mode 100644 index 00000000..598ea093 --- /dev/null +++ b/collects/mred/private/wx/win32/printer-dc.rkt @@ -0,0 +1,219 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/alloc + racket/draw/private/dc + racket/draw/private/local + racket/draw/unsafe/cairo + racket/draw/private/record-dc + racket/draw/private/bitmap-dc + racket/draw/private/ps-setup + "../../lock.rkt" + "dc.rkt" + "types.rkt" + "utils.rkt" + "const.rkt") + +(provide + (protect-out printer-dc% + show-print-setup)) + +(define _HGLOBAL _pointer) + +(define-cstruct _PAGESETUPDLG + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hDevMode _HGLOBAL] + [hDevNames _HGLOBAL] + [Flags _DWORD] + [ptPaperSize _POINT] + [rtMinMargin _RECT] + [rtMargin _RECT] + [hInstance _HINSTANCE] + [lCustData _LPARAM] + [lpfnPageSetupHook _fpointer] + [lpfnPagePaintHook _fpointer] + [lpPageSetupTemplateName _pointer] + [hPageSetupTemplate _HGLOBAL])) + +(define-cstruct _PRINTDLG + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hDevMode _HGLOBAL] + [hDevNames _HGLOBAL] + [hDC _HDC] + [Flags _DWORD] + [nFromPage _WORD] + [nToPage _WORD] + [nMinPage _WORD] + [nMaxPage _WORD] + [nCopies _WORD] + [hInstance _HINSTANCE] + [lCustData _LPARAM] + [lpfnPrintHook _fpointer] + [lpfnSetupHook _fpointer] + [lpPrintTemplateName _pointer] + [lpSetupTemplateName _pointer] + [hPrintTemplate _HGLOBAL] + [hSetupTemplate _HGLOBAL]) + #:alignment 2) + +(define-cstruct _DOCINFO + ([cbSize _int] + [lpszDocName _permanent-string/utf-16] + [lpszOutput _pointer] + [lpszDatatype _pointer] + [fwType _DWORD])) + +(define PD_RETURNDC #x00000100) + +(define PSD_INTHOUSANDTHSOFINCHES #x00000004) +(define PSD_INHUNDREDTHSOFMILLIMETERS #x00000008) + +(define-comdlg32 PageSetupDlgW (_wfun _PAGESETUPDLG-pointer -> _BOOL)) +(define-comdlg32 PrintDlgW (_wfun _PRINTDLG-pointer -> _BOOL)) + +(define-gdi32 StartDocW (_wfun _HDC _DOCINFO-pointer -> _int)) +(define-gdi32 StartPage (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'StartPage)))) +(define-gdi32 EndPage (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'EndPage)))) +(define-gdi32 EndDoc (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'EndDoc)))) + +(define needs-delete ((allocator DeleteDC) values)) + +(define (clone-page-setup p) + (let ([new-p (malloc 1 _PAGESETUPDLG)]) + (set-cpointer-tag! new-p PAGESETUPDLG-tag) + (memcpy new-p 0 p 1 _PAGESETUPDLG) + new-p)) + +(define PSD_RETURNDEFAULT #x00000400) + +(define (show-print-setup parent [just-create? #f]) + (let* ([pss (current-ps-setup)] + [ps (send pss get-native)]) + (atomically + (let ([p (malloc 'raw 1 _PAGESETUPDLG)]) + (set-cpointer-tag! p PAGESETUPDLG-tag) + (if ps + (memcpy p 0 ps 1 _PAGESETUPDLG) + (begin + (memset p 0 1 _PAGESETUPDLG) + (set-PAGESETUPDLG-lStructSize! p (ctype-sizeof _PAGESETUPDLG)))) + (set-PAGESETUPDLG-Flags! p (if just-create? + PSD_RETURNDEFAULT + 0)) + (let ([r (PageSetupDlgW p)]) + (when r + (let ([new-p (clone-page-setup p)]) + (send pss set-native new-p values))) + (free p) + ;; FIXME: `r' leaks handles through + ;; the hDevModes and hDevNames fields + r))))) + +(define printer-dc% + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object win32-bitmap% 1 1 #f)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define page-setup (or (send (current-ps-setup) get-native) + (begin + (show-print-setup #f #t) + (send (current-ps-setup) get-native)))) + + (define-values (page-width page-height) + (let ([scale (if (zero? (bitwise-and (PAGESETUPDLG-Flags page-setup) + PSD_INTHOUSANDTHSOFINCHES)) + ;; 100ths of mm + (/ 72.0 (/ 10.0 2.54)) + ;; 1000ths of in + (/ 72.0 1000.0))]) + (values + (* scale (POINT-x (PAGESETUPDLG-ptPaperSize page-setup))) + (* scale (POINT-y (PAGESETUPDLG-ptPaperSize page-setup)))))) + + + + (define/override (get-size) (values page-width page-height)) + + (define start-doc-message #f) + (define/override (start-doc s) + (super start-doc s) + (set! start-doc-message (and s (string->immutable-string s)))) + + (define/override (end-doc) + (let-values ([(hdc from-page to-page) + (atomically + (let ([p (malloc 'raw 1 _PRINTDLG)]) + (set-cpointer-tag! p PRINTDLG-tag) + (memset p 0 1 _PRINTDLG) + (set-PRINTDLG-lStructSize! p (ctype-sizeof _PRINTDLG)) + (set-PRINTDLG-hDevMode! p (PAGESETUPDLG-hDevMode page-setup)) + (set-PRINTDLG-hDevNames! p (PAGESETUPDLG-hDevNames page-setup)) + (set-PRINTDLG-Flags! p (bitwise-ior PD_RETURNDC)) + (set-PRINTDLG-nFromPage! p 1) + (set-PRINTDLG-nToPage! p (length pages)) + (set-PRINTDLG-nMinPage! p 1) + (set-PRINTDLG-nMaxPage! p (length pages)) + (set-PRINTDLG-nCopies! p 1) + (let ([r (PrintDlgW p)]) + (begin0 + (if r + (values (needs-delete (PRINTDLG-hDC p)) + (PRINTDLG-nFromPage p) + (PRINTDLG-nToPage p)) + (values #f #f #f)) + (free p)))))]) + (when hdc + (atomically + (let ([job + (let ([di (make-DOCINFO (ctype-sizeof _DOCINFO) + start-doc-message + #f + #f + 0)]) + (begin0 + (StartDocW hdc di) + (when start-doc-message + (free (DOCINFO-lpszDocName di)))))]) + (when (positive? job) + (for ([proc (in-list (reverse pages))] + [page-no (in-naturals 1)]) + (when (<= from-page page-no to-page) + (StartPage hdc) + (let* ([s (cairo_win32_surface_create hdc)] + [cr (cairo_create s)]) + (set-point-scale hdc cr) + (proc + (make-object + (class (dc-mixin default-dc-backend%) + (super-new) + (define/override (init-cr-matrix cr) + (set-point-scale hdc cr)) + (define/override (get-cr) cr)))) + (cairo_destroy cr) + (cairo_surface_destroy s)) + (EndPage hdc))) + (EndDoc hdc)) + (DeleteDC hdc)))))))) + +(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) + +(define LOGPIXELSX 88) +(define LOGPIXELSY 90) + +(define (set-point-scale hdc cr) + (let* ([lpx (GetDeviceCaps hdc LOGPIXELSX)] + [lpy (GetDeviceCaps hdc LOGPIXELSY)] + [lx (/ (if (zero? lpx) 300 lpx) 72.0)] + [ly (/ (if (zero? lpy) 300 lpy) 72.0)]) + (cairo_scale cr lx ly))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt new file mode 100644 index 00000000..c88d403c --- /dev/null +++ b/collects/mred/private/wx/win32/procs.rkt @@ -0,0 +1,118 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "../../syntax.rkt" + "theme.rkt" + "types.rkt" + "utils.rkt" + "const.rkt" + "menu-item.rkt" + "frame.rkt" + "window.rkt" + "dc.rkt" + "printer-dc.rkt" + "../common/printer.rkt" + (except-in "../common/default-procs.rkt" + get-panel-background) + "filedialog.rkt" + "colordialog.rkt" + "sound.rkt" + racket/draw) + +(provide + (protect-out + color-from-user-platform-mode + get-font-from-user + font-from-user-platform-mode + get-panel-background + find-graphical-system-path + register-collecting-blit + unregister-collecting-blit + shortcut-visible-in-label? + run-printout + get-double-click-time + get-control-font-face + get-control-font-size + get-control-font-size-in-pixels? + cancel-quit + bell + hide-cursor + get-display-depth + is-color-display? + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color + check-for-break) + flush-display + fill-private-color + play-sound + location->window + file-selector + show-print-setup + id-to-menu-item + file-creator-and-type + display-origin + display-size + make-screen-bitmap + make-gl-bitmap + special-control-key + special-option-key + get-color-from-user) + + +(define (find-graphical-system-path what) + #f) + +(define (cancel-quit) (void)) + +(define (color-from-user-platform-mode) 'dialog) + +(define (font-from-user-platform-mode) #f) +(define-unimplemented get-font-from-user) + +(define (get-panel-background) + (let ([c (GetSysColor COLOR_BTNFACE)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) +(define (shortcut-visible-in-label? [? #f]) #t) + +(define run-printout (make-run-printout printer-dc%)) + +(define (get-double-click-time) 500) +(define (get-control-font-face) (get-theme-font-face)) +(define (get-control-font-size) (get-theme-font-size)) +(define (get-control-font-size-in-pixels?) #t) + +(define-user32 MessageBeep (_wfun _UINT -> _BOOL)) +(define (bell) + (void (MessageBeep MB_OK))) + +(define (hide-cursor) (void)) + +(define (get-display-depth) 32) + +(define (is-color-display?) #t) + +(define (can-show-print-setup?) #t) + +(define (get-highlight-background-color) + (let ([c (GetSysColor COLOR_HIGHLIGHT)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) +(define (get-highlight-text-color) + (let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (make-object win32-bitmap% w h #f)) + +(define/top (make-gl-bitmap [exact-positive-integer? w] + [exact-positive-integer? h] + [gl-config% c]) + (make-object win32-bitmap% w h #f c)) + +(define (check-for-break) #f) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt new file mode 100644 index 00000000..774aa77c --- /dev/null +++ b/collects/mred/private/wx/win32/queue.rkt @@ -0,0 +1,159 @@ +#lang racket/base +(require ffi/unsafe + racket/class + ffi/unsafe/alloc + ffi/unsafe/try-atomic + "utils.rkt" + "types.rkt" + "const.rkt" + "key.rkt" + "wndclass.rkt" + "../../lock.rkt" + "../common/queue.rkt") + +(provide (protect-out win32-start-event-pump) + + ;; from common/queue: + current-eventspace + queue-event + queue-refresh-event + yield) + +;; ------------------------------------------------------------ +;; Win32 event pump + +(define _LPMSG _pointer) + +(define-user32 GetQueueStatus (_wfun _UINT -> _DWORD)) +(define-user32 GetMessageW (_wfun _LPMSG _HWND _UINT _UINT -> _BOOL)) +(define-user32 PeekMessageW (_wfun _LPMSG _HWND _UINT _UINT _UINT -> _BOOL)) +(define-user32 TranslateMessage (_wfun _LPMSG -> _BOOL)) +(define-user32 DispatchMessageW (_wfun _LPMSG -> _LRESULT)) +(define-user32 PostQuitMessage (_wfun _int -> _void)) +(define-user32 EnumThreadWindows (_wfun _DWORD _fpointer _LPARAM -> _BOOL)) +(define-user32 GetWindow (_wfun _HWND _UINT -> _HWND)) +(define-kernel32 GetCurrentThreadId (_wfun -> _DWORD)) + +(define _enum_proc (_wfun _HWND _LPARAM -> _BOOL)) + +(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void)) + +(define free-msg + ((deallocator) + (lambda (msg) + (free msg)))) + +(define malloc-msg + ((allocator free-msg) + (lambda () + (malloc _MSG 'raw)))) + +(define (events-ready?) + ;; Check for events only since the last PeekMessage: + (not (zero? (LOWORD (GetQueueStatus QS_ALLINPUT))))) + +(define (install-wakeup fds) + (pre-event-sync #t) + (scheme_add_fd_eventmask fds QS_ALLINPUT)) + +(set-check-queue! events-ready?) +(set-queue-wakeup! install-wakeup) + +(define other-peek-evt (make-semaphore)) +(define peek-other-peek-evt (semaphore-peek-evt other-peek-evt)) + +(define (message-dequeue es hwnd) + ;; Called in the eventspace for hwnd: + (let ([t (eventspace-extra-table es)] + [id (cast hwnd _HWND _intptr)]) + (atomically (hash-remove! t id)) + (let ([msg (malloc-msg)]) + (let loop () + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + ;; Since we called PeekMeessage in a thread other than the + ;; event-pump thread, set `other-peek-evt' so the pump + ;; knows to check again. + (unless (sync/timeout 0 peek-other-peek-evt) + (semaphore-post other-peek-evt)) + ;; Now handle the event: + (when v + (unless (generates-key-event? (cast msg _pointer _MSG-pointer)) + (TranslateMessage msg)) + (call-as-nonatomic-retry-point + (lambda () + ;; in atomic mode: + (DispatchMessageW msg))) + ;; Maybe there's another event for this window: + (loop)))) + (free-msg msg)))) + +(define (queue-message-dequeue es hwnd) + ;; in atomic mode + (let ([t (eventspace-extra-table es)] + [id (cast hwnd _HWND _intptr)]) + (unless (hash-ref t id #f) + (hash-set! t id #t) + (queue-event es (lambda () (message-dequeue es hwnd)))))) + +;; For use only in the event-pump thread: +(define msg (malloc-msg)) + +(define (check-window-event hwnd data) + ;; in atomic mode + (let* ([root (let loop ([hwnd hwnd]) + (let ([p (GetWindow hwnd GW_OWNER)]) + (if p + (loop p) + hwnd)))] + [wx (any-hwnd->wx root)]) + (if wx + ;; One of our windows, so make sure its eventspace + ;; asks for the message: + (let ([v (PeekMessageW msg hwnd 0 0 PM_NOREMOVE)]) + (when v + (queue-message-dequeue (send wx get-eventspace) + hwnd))) + ;; Not our window, so dispatch any available events + (let loop () + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop))))) + #t)) + +(define check_window_event (function-ptr check-window-event _enum_proc)) + +(define (dispatch-all-ready) + ;; in atomic mode + (pre-event-sync #f) + (clean-up-destroyed) + + ;; Windows uses messages above #x4000 to hilite items in the task bar, + ;; etc. In any case, these messages won't be handled by us, so they + ;; can't trigger callbacks. + (let loop () + (let ([v (PeekMessageW msg #f #x4000 #xFFFF PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop)))) + + ;; Per-window checking lets us put an event in the right + ;; eventspace: + (EnumThreadWindows (GetCurrentThreadId) check_window_event 0)) + +(define (win32-start-event-pump) + (thread (lambda () + (let loop () + (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) + (sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001)) + queue-evt + other-peek-evt + (if any-tasks? + (wrap-evt (system-idle-evt) + (lambda (v) #f)) + boundary-tasks-ready-evt))) + (pre-event-sync #t)) + (as-entry dispatch-all-ready) + (loop))))) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt new file mode 100644 index 00000000..bb9c9de7 --- /dev/null +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -0,0 +1,159 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") + +(provide + (protect-out radio-box%)) + +(define SEP 4) +(define BM_SETCHECK #x00F1) + +(define radio-box% + (class item% + (init parent cb label + x y w h + labels + val + style + font) + + (inherit auto-size set-control-font + is-enabled-to-root? + set-focus) + + (define callback cb) + (define current-value val) + + (define hwnd + (CreateWindowExW 0 + "PLTTabPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define label-bitmaps null) + + (define radio-hwnds + (let loop ([y 0] [w 0] [labels labels]) + (if (null? labels) + (begin + (MoveWindow hwnd 0 0 w y #t) + null) + (let* ([label (car labels)] + [bitmap? (and (label . is-a? . bitmap%) + (send label ok?))] + [radio-hwnd + (CreateWindowExW/control 0 + "PLTBUTTON" + (if (string? label) + label + "") + (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + hwnd + #f + hInstance + #f)]) + (when bitmap? + (let ([hbitmap (bitmap->hbitmap label)]) + (set! label-bitmaps (cons hbitmap label-bitmaps)) + (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP + (cast hbitmap _HBITMAP _LPARAM)))) + (ShowWindow radio-hwnd SW_SHOW) + (set-control-font font radio-hwnd) + (let-values ([(w1 h) + (auto-size font label 0 0 20 4 + (lambda (w h) + (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) + (values w h)))]) + (cons radio-hwnd + (loop (+ y SEP h) (max w1 w) (cdr labels)))))))) + + (unless (= val -1) + (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) + + (super-new [callback cb] + [parent parent] + [hwnd hwnd] + [extra-hwnds radio-hwnds] + [style style]) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? hwnd a-hwnd) + (for/or ([radio-hwnd (in-list radio-hwnds)]) + (ptr-equal? a-hwnd radio-hwnd)))) + + (define/override (is-command? cmd) + (= cmd BN_CLICKED)) + + (define/public (do-command cmd control-hwnd) + (let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)] + [pos (in-naturals)]) + (if (ptr-equal? control-hwnd radio-hwnd) + pos + i))]) + (unless (= val current-value) + (set-selection val) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))))))) + + + (define focused 0) + + (define/public (button-focus i) + (if (= i -1) + (min focused (length radio-hwnds)) + (begin + (set! focused i) + (set-focus (list-ref radio-hwnds i))))) + + (define/override (get-focus-hwnd) + (if (= focused -1) + hwnd + (list-ref radio-hwnds focused))) + + (define/public (set-selection val) + (atomically + (unless (= val current-value) + (unless (= current-value -1) + (SendMessageW (list-ref radio-hwnds current-value) BM_SETCHECK 0 0)) + (unless (= val -1) + (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) + (set! current-value val)))) + + (define buttons-enabled (make-vector (length radio-hwnds) #t)) + (define/public (enable-button i on?) + (unless (eq? (and on? #t) (vector-ref buttons-enabled i)) + (vector-set! buttons-enabled i (and on? #t)) + (when (is-enabled-to-root?) + (void (EnableWindow (list-ref radio-hwnds i) on?))))) + (define/override (internal-enable on?) + (for ([radio-hwnd (in-list radio-hwnds)] + [radio-on? (in-vector buttons-enabled)]) + (void (EnableWindow radio-hwnd (and on? radio-on?))))) + + (define/public (get-selection) current-value) + + (define/public (number) (length radio-hwnds)))) + diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt new file mode 100644 index 00000000..6f003c63 --- /dev/null +++ b/collects/mred/private/wx/win32/slider.rkt @@ -0,0 +1,161 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") + +(provide + (protect-out slider%)) + +(define TBS_VERT #x0002) +(define TBS_HORZ #x0000) + +(define TBM_GETPOS WM_USER) +(define TBM_GETRANGEMIN (+ WM_USER 1)) +(define TBM_GETRANGEMAX (+ WM_USER 2)) +(define TBM_GETTIC (+ WM_USER 3)) +(define TBM_SETTIC (+ WM_USER 4)) +(define TBM_SETPOS (+ WM_USER 5)) +(define TBM_SETRANGE (+ WM_USER 6)) +(define TBM_SETRANGEMIN (+ WM_USER 7)) +(define TBM_SETRANGEMAX (+ WM_USER 8)) + +(define SS_CENTER #x00000001) + +(define THICKNESS 24) +(define MIN_LENGTH 80) + +(defclass slider% item% + (init parent cb + label + val lo hi + x y w + style + font) + (inherit set-control-font + auto-size) + + (define callback cb) + (define vertical? (memq 'vertical style)) + + (define panel-hwnd + (if (memq 'plain style) + #f + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f))) + + (define slider-hwnd + (CreateWindowExW/control 0 + "PLTmsctls_trackbar32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if vertical? + TBS_VERT + TBS_HORZ) + (if panel-hwnd + WS_VISIBLE + 0)) + 0 0 0 0 + (or panel-hwnd + (send parent get-client-hwnd)) + #f + hInstance + #f)) + + (define value-hwnd + (and panel-hwnd + (CreateWindowExW/control 0 + "STATIC" + (format "~s" val) + (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) + 0 0 0 0 + panel-hwnd + #f + hInstance + #f))) + + (define hwnd (or panel-hwnd slider-hwnd)) + + (super-new [callback cb] + [parent parent] + [hwnd hwnd] + [extra-hwnds + (if panel-hwnd + (list slider-hwnd value-hwnd) + null)] + [style style]) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? hwnd a-hwnd) + (and panel-hwnd + (or (ptr-equal? slider-hwnd a-hwnd) + (ptr-equal? value-hwnd a-hwnd))))) + + (when value-hwnd + (set-control-font font value-hwnd)) + + (define value-w 0) + (define value-h 0) + + (if panel-hwnd + (auto-size font + (list (format "~s" lo) + (format "~s" hi)) + 0 0 0 0 (lambda (w h) + (set! value-w w) + (set! value-h h) + (if vertical? + (set-size -11111 -11111 (+ THICKNESS w) (max h MIN_LENGTH)) + (set-size -11111 -11111 (max w MIN_LENGTH) (+ THICKNESS h))))) + (if vertical? + (set-size -11111 -11111 THICKNESS MIN_LENGTH) + (set-size -11111 -11111 MIN_LENGTH THICKNESS))) + + (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) + (set-value val) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when panel-hwnd + (unless (or (= w -1) (= h -1)) + (if vertical? + (let ([dx (quotient (- w THICKNESS value-w) 2)]) + (MoveWindow slider-hwnd dx 0 THICKNESS h #T) + (MoveWindow value-hwnd (+ dx THICKNESS) (quotient (- h value-h) 2) value-w value-h #t)) + (let ([dy (quotient (- h THICKNESS value-h) 2)]) + (MoveWindow slider-hwnd 0 dy w THICKNESS #t) + (MoveWindow value-hwnd (quotient (- w value-w) 2) (+ dy THICKNESS) value-w value-h #t)))))) + + (define/override (control-scrolled) + (when value-hwnd + (set-text (get-value))) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)]))))) + + (define/public (set-value val) + (SendMessageW slider-hwnd TBM_SETPOS 1 val) + (when value-hwnd + (set-text val))) + + (define/private (set-text val) + (SetWindowTextW value-hwnd (format "~s" val))) + + (define/public (get-value) + (SendMessageW slider-hwnd TBM_GETPOS 0 0))) diff --git a/collects/mred/private/wx/win32/sound.rkt b/collects/mred/private/wx/win32/sound.rkt new file mode 100644 index 00000000..fb526058 --- /dev/null +++ b/collects/mred/private/wx/win32/sound.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "const.rkt") + +(provide + (protect-out play-sound)) + +(define-winmm PlaySoundW (_wfun _string/utf-16 _pointer _DWORD -> _BOOL)) + +(define SND_SYNC #x0000) +(define SND_ASYNC #x0001) + +(define (play-sound path async?) + (let ([path (simplify-path path #f)]) + ;; FIXME: sync sound play blocks all Racket threads + (PlaySoundW (if (path? path) (path->string path) path) + #f + (if async? SND_ASYNC SND_SYNC)))) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt new file mode 100644 index 00000000..a85aaf96 --- /dev/null +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -0,0 +1,174 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "panel.rkt" + "wndclass.rkt" + "types.rkt") + +(provide + (protect-out tab-panel%)) + +(define TCIF_TEXT #x0001) +(define TCM_SETUNICODEFORMAT #x2005) +(define TCM_FIRST #x1300) +(define TCM_INSERTITEMW (+ TCM_FIRST 62)) +(define TCM_SETITEMW (+ TCM_FIRST 61)) +(define TCM_SETCURSEL (+ TCM_FIRST 12)) +(define TCM_GETCURSEL (+ TCM_FIRST 11)) +(define TCM_GETITEMCOUNT (+ TCM_FIRST 4)) +(define TCM_DELETEITEM (+ TCM_FIRST 8)) +(define TCM_DELETEALLITEMS (+ TCM_FIRST 9)) + +(define-cstruct _TCITEMW + ([mask _UINT] + [dwState _DWORD] + [dwStateMask _DWORD] + [pszText _permanent-string/utf-16] + [cchTextMax _int] + [iImage _int] + [lParam _LPARAM])) + +(define tab-panel% + (class (item-mixin (panel-mixin window%)) + (init parent + x y w h + style + choices) + + (define callback void) + + (inherit auto-size set-control-font + is-shown-to-root?) + + (define hwnd + (CreateWindowExW/control 0 + "PLTSysTabControl32" + "" + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define client-hwnd + (CreateWindowExW 0 + "PLTTabPanel" + #f + (bitwise-ior WS_CHILD WS_VISIBLE) + 0 0 w h + hwnd + #f + hInstance + #f)) + + (super-new [callback (lambda (c) (callback c))] + [extra-hwnds (list client-hwnd)] + [parent parent] + [hwnd hwnd] + [style style]) + + (define/override (get-client-hwnd) + client-hwnd) + + (SendMessageW hwnd TCM_SETUNICODEFORMAT 1 0) + + (define/private (with-item proc) + (atomically + (let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)]) + (set-TCITEMW-mask! item TCIF_TEXT) + (proc item + (lambda () (free (TCITEMW-pszText item))) + (lambda (msg w) + (SendMessageW hwnd msg w (cast item _pointer _LPARAM)))) + (free item)))) + + (set choices) + + (define tab-height 0) + + (set-control-font #f) + (auto-size #f + (if (null? choices) + '("Choice") + choices) + 0 0 0 0 #:combine-width + + (lambda (w h) + (set! tab-height (+ h 6)) + (set-size -11111 -11111 + (+ w (* 6 (length choices))) + (+ h 12)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (unless (or (= w -1) (= h -1)) + (MoveWindow client-hwnd 1 (+ tab-height 2) (- w 4) (- h tab-height 6) #t))) + + (define/override (is-command? cmd) + (= cmd 64985)) + + (define/public (do-command cmd control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'tab-panel] + [time-stamp (current-milliseconds)]))))) + + ;; Needed after some actions: + (define/private (refresh) + (InvalidateRect hwnd #f #f)) + + (define/public (set-label pos str) + (with-item + (lambda (item done-str send-msg) + (set-TCITEMW-pszText! item str) + (send-msg TCM_SETITEMW pos) + (done-str))) + (refresh)) + + (define/public (set-selection pos) + (SendMessageW hwnd TCM_SETCURSEL pos 0) + (refresh)) + + (define/public (get-selection) + (SendMessageW hwnd TCM_GETCURSEL 0 0)) + + (define/public (number) + (SendMessageW hwnd TCM_GETITEMCOUNT 0 0)) + + (define/public (delete pos) + (SendMessageW hwnd TCM_DELETEITEM pos 0) + (refresh)) + + (public [append* append]) + (define (append* str) + (with-item + (lambda (item done-str send-msg) + (set-TCITEMW-pszText! item str) + (send-msg TCM_INSERTITEMW (number)) + (done-str))) + (refresh)) + + (define/public (set choices) + (let ([sel (get-selection)]) + (SendMessageW hwnd TCM_DELETEALLITEMS 0 0) + (with-item + (lambda (item done-str send-msg) + (for ([str (in-list choices)] + [pos (in-naturals)]) + (set-TCITEMW-pszText! item str) + (send-msg TCM_INSERTITEMW pos) + (done-str)))) + (let ([sel (max 0 (min (length choices) sel))]) + (set-selection sel)))) + + (define/public (set-callback cb) + (set! callback cb)))) + diff --git a/collects/mred/private/wx/win32/theme.rkt b/collects/mred/private/wx/win32/theme.rkt new file mode 100644 index 00000000..6b1e21f1 --- /dev/null +++ b/collects/mred/private/wx/win32/theme.rkt @@ -0,0 +1,102 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/alloc + "utils.ss" + "const.ss" + "types.ss") + +(provide + (protect-out get-theme-logfont + get-theme-font-face + get-theme-font-size + _LOGFONT-pointer + OpenThemeData + CloseThemeData + DrawThemeParentBackground + DrawThemeBackground + DrawThemeEdge + EnableThemeDialogTexture)) + +(define _HTHEME (_cpointer 'HTHEME)) + +(define-cstruct _FaceName1 + ([c1 _uint16] + [c2 _uint16] + [c3 _uint16] + [c4 _uint16] + [c5 _uint16] + [c6 _uint16] + [c7 _uint16] + [c8 _uint16])) + +(define-cstruct _FaceName + ([f1 _FaceName1] + [f2 _FaceName1] + [f3 _FaceName1] + [f4 _FaceName1])) + +(define-cstruct _LOGFONT + ([lfHeight _LONG] + [lfWidth _LONG] + [lfEscapement _LONG] + [lfOrientation _LONG] + [lfWeight _LONG] + [lfItalic _BYTE] + [lfUnderline _BYTE] + [lfStrikeOut _BYTE] + [lfCharSet _BYTE] + [lfOutPrecision _BYTE] + [lfClipPrecision _BYTE] + [lfQuality _BYTE] + [lfPitchAndFamily _BYTE] + [lfFaceName _FaceName])) ; 32 of them + +(define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT) + -> (when (negative? r) + (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r)))) + #:wrap (deallocator)) +(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME) + #:wrap (allocator CloseThemeData)) +(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT)) + -> (r : _HRESULT) + -> (if (negative? r) + (error 'GetThemeFont "failed: ~s" (bitwise-and #xFFFF r)) + f))) + +(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONT)) + -> (r : _HRESULT) + -> (if (negative? r) + (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r)) + f))) + +(define-uxtheme DrawThemeBackground (_wfun _HTHEME _HDC _int _int _RECT-pointer (_or-null _RECT-pointer) -> (r : _HRESULT) + -> (when (negative? r) + (error 'DrawThemeBackground "failed: ~s" (bitwise-and #xFFFF r))))) +(define-uxtheme DrawThemeParentBackground (_wfun _HWND _HDC _pointer -> (r : _HRESULT) + -> (when (negative? r) + (error 'DrawThemeParentBackground "failed: ~s" (bitwise-and #xFFFF r))))) +(define-uxtheme DrawThemeEdge (_wfun _HWND _HDC _int _int _RECT-pointer _int _int _RECT-pointer -> (r : _HRESULT) + -> (when (negative? r) + (error 'DrawThemeEdge "failed: ~s" (bitwise-and #xFFFF r))))) + +(define-uxtheme EnableThemeDialogTexture (_wfun _HWND _DWORD -> (r : _HRESULT) + -> (when (negative? r) + (error 'EnableThemeDialogTexture "failed: ~s" (bitwise-and #xFFFF r))))) + +(define BP_PUSHBUTTON 1) +(define PBS_NORMAL 1) +(define TMT_FONT 210) +(define TMT_BODYFONT 809) + +(define TMT_MSGBOXFONT 805) + +(define theme-logfont (GetThemeSysFont #f TMT_MSGBOXFONT)) + +(define (get-theme-logfont) + theme-logfont) + +(define (get-theme-font-face) + (cast (LOGFONT-lfFaceName theme-logfont) _pointer _string/utf-16)) + +(define (get-theme-font-size) + (abs (LOGFONT-lfHeight theme-logfont))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt new file mode 100644 index 00000000..288dfa4b --- /dev/null +++ b/collects/mred/private/wx/win32/types.rkt @@ -0,0 +1,143 @@ +#lang racket/base +(require ffi/unsafe) + +(provide + (protect-out _wfun + + _WORD + _DWORD + _UDWORD + _ATOM + _WPARAM + _LPARAM + _LRESULT + _BOOL + _UINT + _UINT_PTR + _BYTE + _LONG + _ULONG + _SHORT + _HRESULT + _WCHAR + _SIZE_T + _INT_PTR + + _HINSTANCE + _HWND + _HMENU + _HICON + _HCURSOR + _HBRUSH + _HDC + _HFONT + _HBITMAP + _HANDLE + + _COLORREF + + _fnpointer + + _permanent-string/utf-16 + utf-16-length + + (struct-out POINT) _POINT _POINT-pointer + (struct-out RECT) _RECT _RECT-pointer + (struct-out MSG) _MSG _MSG-pointer + + HIWORD + LOWORD + MAKELONG + MAKELPARAM)) + +(define win64? (equal? "win32\\x86_64" (path->string (system-library-subpath #f)))) +(define win_abi (if win64? #f 'stdcall)) + +(define-syntax-rule (_wfun . a) + (_fun #:abi win_abi . a)) + +(define _WORD _int16) +(define _DWORD _int32) +(define _UDWORD _uint32) +(define _ATOM _int) +(define _UINT_PTR _uintptr) +(define _WPARAM _intptr) ; supposed to be _UINT_PTR, but we have some sign mismatch +(define _LONG_PTR _intptr) +(define _LPARAM _LONG_PTR) +(define _LRESULT _LONG_PTR) +(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) +(define _UINT _uint) +(define _BYTE _uint8) +(define _HRESULT _long) +(define _WCHAR _int16) +(define _SIZE_T _long) +(define _INT_PTR _intptr) + +(define _HINSTANCE (_cpointer/null 'HINSTANCE)) +(define _HWND (_cpointer/null 'HWND)) +(define _HMENU (_cpointer/null 'HMENU)) +(define _HICON (_cpointer/null 'HICON)) +(define _HCURSOR (_cpointer/null 'HCURSOR)) +(define _HBRUSH (_cpointer/null 'HBRUSH)) +(define _HDC (_cpointer/null 'HDC)) +(define _HFONT (_cpointer/null 'HFONT)) +(define _HBITMAP (_cpointer/null 'HBITMAP)) +(define _HANDLE (_cpointer/null 'HANDLE)) + +(define _COLORREF _DWORD) + +(define _fnpointer (_or-null _fpointer)) + +(define (utf-16-length s) + (for/fold ([len 0]) ([c (in-string s)]) + (+ len + (if ((char->integer c) . > . #xFFFF) + 2 + 1)))) + +(define _permanent-string/utf-16 + (make-ctype _pointer + (lambda (s) + (and s + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([p (ptr-ref v _gcpointer)]) + (let ([len (+ 1 (utf-16-length s))]) + (let ([c (malloc len _uint16 'raw)]) + (memcpy c p len _uint16) + c)))))) + (lambda (p) p))) + +(define _LONG _long) +(define _ULONG _ulong) +(define _SHORT _short) + +(define-cstruct _POINT ([x _LONG] + [y _LONG])) + +(define-cstruct _RECT ([left _LONG] + [top _LONG] + [right _LONG] + [bottom _LONG])) + +(define-cstruct _MSG ([hwnd _HWND] + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) + +(define (short v) + (if (zero? (bitwise-and #x8000 v)) + v + (bitwise-ior v (arithmetic-shift -1 15)))) + +(define (HIWORD v) + (short (arithmetic-shift v -16))) +(define (LOWORD v) + (short (bitwise-and v #xFFFF))) + +(define (MAKELONG a b) + (bitwise-ior (arithmetic-shift b 16) + (bitwise-and a #xFFFF))) +(define (MAKELPARAM a b) (MAKELONG a b)) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt new file mode 100644 index 00000000..bf9020a1 --- /dev/null +++ b/collects/mred/private/wx/win32/utils.rkt @@ -0,0 +1,144 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + "../common/utils.rkt" + "types.rkt") + +(provide + define-mz + (protect-out define-gdi32 + define-user32 + define-kernel32 + define-comctl32 + define-comdlg32 + define-shell32 + define-uxtheme + define-winmm + failed + + GetLastError + + GetWindowLongPtrW + SetWindowLongPtrW + SendMessageW SendMessageW/str + GetSysColor GetRValue GetGValue GetBValue make-COLORREF + CreateBitmap + CreateCompatibleBitmap + DeleteObject + CreateCompatibleDC + DeleteDC + MoveWindow + ShowWindow + EnableWindow + SetWindowTextW + SetCursor + GetDC + ReleaseDC + InvalidateRect + ValidateRect + GetMenuState + CheckMenuItem + ModifyMenuW + RemoveMenu + SelectObject)) + +(define gdi32-lib (ffi-lib "gdi32.dll")) +(define user32-lib (ffi-lib "user32.dll")) +(define kernel32-lib (ffi-lib "kernel32.dll")) +(define comctl32-lib (ffi-lib "comctl32.dll")) +(define comdlg32-lib (ffi-lib "comdlg32.dll")) +(define shell32-lib (ffi-lib "shell32.dll")) +(define uxtheme-lib (ffi-lib "uxtheme.dll")) +(define winmm-lib (ffi-lib "winmm.dll")) + +(define-ffi-definer define-gdi32 gdi32-lib) +(define-ffi-definer define-user32 user32-lib) +(define-ffi-definer define-kernel32 kernel32-lib) +(define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-comdlg32 comdlg32-lib) +(define-ffi-definer define-shell32 shell32-lib) +(define-ffi-definer define-uxtheme uxtheme-lib) +(define-ffi-definer define-winmm winmm-lib) + +(define-kernel32 GetLastError (_wfun -> _DWORD)) + +(define (failed who) + (error who "call failed (~s)" + (GetLastError))) + +(define is-win64? + (equal? "win32\\x86_64" + (path->string (system-library-subpath #f)))) + +(define GetWindowLongPtrW + (get-ffi-obj (if is-win64? 'GetWindowLongPtrW 'GetWindowLongW) user32-lib + (_wfun _HWND _int -> _pointer))) +(define SetWindowLongPtrW + (get-ffi-obj (if is-win64? 'SetWindowLongPtrW 'SetWindowLongW) user32-lib + (_wfun _HWND _int _pointer -> _pointer))) + +(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) + #:c-id SendMessageW) + +(define-user32 GetSysColor (_wfun _int -> _DWORD)) + +(define (GetRValue v) (bitwise-and v #xFF)) +(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) +(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) +(define (make-COLORREF r g b) (bitwise-ior + r + (arithmetic-shift g 8) + (arithmetic-shift b 16))) + +(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'MoveWindow)))) + +(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) +(define-user32 EnableWindow (_wfun _HWND _BOOL -> _BOOL)) + +(define-user32 SetWindowTextW (_wfun _HWND _string/utf-16 -> (r : _BOOL) + -> (unless r (failed 'SetWindowText)))) + +(define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR)) + +(define-user32 _GetDC (_wfun _HWND -> _HDC) + #:c-id GetDC) +(define (GetDC hwnd) + (((allocator (lambda (hdc) (ReleaseDC hwnd hdc))) + _GetDC) + hwnd)) + +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int) + #:wrap (deallocator cadr)) + +(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) + -> (unless r (failed 'DeleteObject))) + #:wrap (deallocator)) + +(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP) + #:wrap (allocator DeleteObject)) +(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP) + #:wrap (allocator DeleteObject)) + +(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) + -> (unless r (failed 'DeleteDC))) + #:wrap (deallocator)) +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC) + #:wrap (allocator DeleteDC)) + +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) + -> (unless r (failed 'InvalidateRect)))) +(define-user32 ValidateRect (_wfun _HWND (_or-null _RECT-pointer) -> (r : _BOOL) + -> (unless r (failed 'ValidateRect)))) + +(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT)) +(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD)) +(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16 + -> (r : _BOOL) + -> (unless r (failed 'ModifyMenuW)))) +(define-user32 RemoveMenu (_wfun _HMENU _UINT _UINT -> (r : _BOOL) + -> (unless r (failed 'RemoveMenu)))) + +(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt new file mode 100644 index 00000000..d89efe44 --- /dev/null +++ b/collects/mred/private/wx/win32/window.rkt @@ -0,0 +1,735 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/draw + racket/draw/unsafe/bstr + "../../syntax.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" + "../common/event.rkt" + "../common/local.rkt" + "../../lock.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "queue.rkt" + "theme.rkt" + "cursor.rkt" + "key.rkt" + "font.rkt") + +(provide + (protect-out window% + queue-window-event + queue-window-refresh-event + location->window + flush-display + + GetWindowRect + GetClientRect)) + +(define (unhide-cursor) (void)) + +(define WM_PRINT #x0317) +(define WM_PRINTCLIENT #x0318) + +(define MK_LBUTTON #x0001) +(define MK_RBUTTON #x0002) +(define MK_SHIFT #x0004) +(define MK_CONTROL #x0008) +(define MK_MBUTTON #x0010) +(define MK_XBUTTON1 #x0020) +(define MK_XBUTTON2 #x0040) + +(define HTHSCROLL 6) +(define HTVSCROLL 7) + +(define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> + (if r rect (failed 'GetWindowRect)))) +(define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) -> + (if r rect (failed 'GetClientRect)))) + +(define-user32 ClientToScreen (_wfun _HWND _POINT-pointer -> (r : _BOOL) + -> (unless r (failed 'ClientToScreen)))) +(define-user32 ScreenToClient (_wfun _HWND _POINT-pointer -> (r : _BOOL) + -> (unless r (failed 'ClientToScreen)))) + +(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) + +(define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void)) + +(define _HDROP _pointer) +(define-shell32 DragQueryPoint (_wfun _HDROP (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r p (failed 'DragQueryPoint)))) +(define-shell32 DragQueryFileW (_wfun _HDROP _UINT _pointer _UINT -> _UINT)) +(define-shell32 DragFinish (_wfun _HDROP -> _void)) + +(define-user32 SetCapture (_wfun _HWND -> _HWND)) +(define-user32 ReleaseCapture (_wfun -> _BOOL)) + +(define-user32 WindowFromPoint (_fun _POINT -> _HWND)) +(define-user32 GetParent (_fun _HWND -> _HWND)) + +(define-cstruct _NMHDR + ([hwndFrom _HWND] + [idFrom _pointer] + [code _UINT])) + +(define-user32 GetDialogBaseUnits (_fun -> _LONG)) +(define measure-dc #f) + +(define theme-hfont #f) + +#; +(define-values (dlu-x dlu-y) + (let ([v (GetDialogBaseUnits)]) + (values (* 1/4 (bitwise-and v #xFFFF)) + (* 1/8 (arithmetic-shift v -16))))) + +(define-cstruct _LOGBRUSH + ([lbStyle _UINT] + [lbColor _COLORREF] + [lbHatch _pointer])) + +(define BS_NULL 1) +(define transparent-logbrush (make-LOGBRUSH BS_NULL 0 #f)) + +(define-gdi32 CreateBrushIndirect (_wfun _LOGBRUSH-pointer -> _HBRUSH)) + +(define TRANSPARENT 1) +(define-gdi32 SetBkMode (_wfun _HDC _int -> (r : _int) + -> (when (zero? r) (failed 'SetBkMode)))) + +(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) +(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) + +(define WM_IS_GRACKET (cast (scheme_register_process_global "PLT_WM_IS_GRACKET" #f) + _pointer + _UINT_PTR)) +(define GRACKET_GUID (cast (scheme_register_process_global "PLT_GRACKET_GUID" #f) + _pointer + _bytes)) +(define-cstruct _COPYDATASTRUCT + ([dwData _pointer] + [cbData _DWORD] + [lpData _pointer])) + +(defclass window% object% + (init-field parent hwnd) + (init style + [extra-hwnds null]) + + (super-new) + + (define eventspace (if parent + (send parent get-eventspace) + (current-eventspace))) + + (set-hwnd-wx! hwnd this) + (for ([extra-hwnd (in-list extra-hwnds)]) + (set-hwnd-wx! extra-hwnd this)) + + (define/public (get-hwnd) hwnd) + (define/public (get-client-hwnd) hwnd) + (define/public (get-focus-hwnd) hwnd) + (define/public (get-eventspace) eventspace) + + (define/public (is-hwnd? a-hwnd) + (ptr-equal? hwnd a-hwnd)) + + (define/public (wndproc w msg wParam lParam default) + (if (try-mouse w msg wParam lParam) + 0 + (cond + [(= msg WM_SETFOCUS) + (queue-window-event this (lambda () (on-set-focus))) + 0] + [(= msg WM_KILLFOCUS) + (queue-window-event this (lambda () (on-kill-focus))) + 0] + [(= msg WM_SYSKEYDOWN) + (let ([result (if (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close + (begin + (unhide-cursor) + (default w msg wParam lParam)) + 0)]) + (do-key w msg wParam lParam #f #f void) + result)] + [(= msg WM_KEYDOWN) + (do-key w msg wParam lParam #f #f default)] + [(= msg WM_KEYUP) + (do-key w msg wParam lParam #f #t default)] + [(= msg WM_SYSCHAR) + (let ([result (if (= wParam VK_MENU) + (begin + (unhide-cursor) + (default w msg wParam lParam)) + 0)]) + (do-key w msg wParam lParam #t #f void) + result)] + [(= msg WM_CHAR) + (do-key w msg wParam lParam #t #f default)] + [(= msg WM_MOUSEWHEEL) + (let ([orig-delta (quotient (HIWORD wParam) WHEEL_DELTA)]) + (let loop ([delta (abs orig-delta)]) + (unless (zero? delta) + (do-key w msg (if (negative? orig-delta) + 'wheel-down + 'wheel-up) + lParam #f #f void) + (loop (sub1 delta))))) + 0] + [(= msg WM_COMMAND) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)] + [cmd (HIWORD wParam)]) + (if (and wx (send wx is-command? cmd)) + (begin + (send wx do-command cmd control-hwnd) + 0) + (default w msg wParam lParam)))] + [(= msg WM_NOTIFY) + (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] + [control-hwnd (NMHDR-hwndFrom nmhdr)] + [wx (any-hwnd->wx control-hwnd)] + [cmd (LOWORD (NMHDR-code nmhdr))]) + (if (and wx (send wx is-command? cmd)) + (begin + (send wx do-command cmd control-hwnd) + 0) + (default w msg wParam lParam)))] + [(or (= msg WM_HSCROLL) + (= msg WM_VSCROLL)) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)]) + (if wx + (begin + (send wx control-scrolled) + 0) + (default w msg wParam lParam)))] + [(= msg WM_DROPFILES) + (handle-drop-files wParam) + 0] + ;; for single-instance applications: + [(and (= msg WM_IS_GRACKET) + (positive? WM_IS_GRACKET)) + ;; return 79 to indicate that this is a GRacket window + 79] + ;; also for single-instance: + [(= msg WM_COPYDATA) + (handle-copydata lParam) + 0] + [(= msg WM_INPUTLANGCHANGE) + (reset-key-mapping) + 0] + [else + (default w msg wParam lParam)]))) + + (define/public (is-command? cmd) #f) + (define/public (control-scrolled) #f) + + (define/public (show on?) + (atomically (direct-show on?))) + + (define shown? #f) + (define/public (direct-show on? [on-mode SW_SHOW]) + ;; atomic mode + (set! shown? (and on? #t)) + (register-child-in-parent on?) + (unless on? (not-focus-child this)) + (ShowWindow hwnd (if on? on-mode SW_HIDE))) + (unless (memq 'deleted style) + (show #t)) + + (define/public (on-size w h) (void)) + + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + (define/public (get-handle) hwnd) + + (define enabled? #t) + (define parent-enabled? #t) + (define/public (enable on?) + (unless (eq? enabled? (and on? #t)) + (atomically + (let ([prev? (and enabled? parent-enabled?)]) + (set! enabled? (and on? #t)) + (let ([now? (and parent-enabled? enabled?)]) + (unless (eq? now? prev?) + (internal-enable now?))))))) + (define/public (parent-enable on?) + (unless (eq? on? parent-enabled?) + (let ([prev? (and enabled? parent-enabled?)]) + (set! parent-enabled? (and on? #t)) + (let ([now? (and parent-enabled? enabled?)]) + (unless (eq? prev? now?) + (internal-enable now?)))))) + (define/public (internal-enable on?) + (void (EnableWindow hwnd on?))) + + (define/public (is-window-enabled?) enabled?) + (define/public (is-enabled-to-root?) + (and enabled? parent-enabled?)) + + (define/public (is-shown-to-root?) + (and shown? + (send parent is-shown-to-root?))) + + (define/public (is-shown?) + shown?) + + (define/public (paint-children) (void)) + + (define/public (get-x) + (let ([r (GetWindowRect hwnd)] + [pr (GetWindowRect (send parent get-client-hwnd))]) + (- (RECT-left r) (RECT-left pr)))) + (define/public (get-y) + (let ([r (GetWindowRect hwnd)] + [pr (GetWindowRect (send parent get-client-hwnd))]) + (- (RECT-top r) (RECT-top pr)))) + + (define/public (get-width) + (let ([r (GetWindowRect hwnd)]) + (- (RECT-right r) (RECT-left r)))) + (define/public (get-height) + (let ([r (GetWindowRect hwnd)]) + (- (RECT-bottom r) (RECT-top r)))) + + (define/public (set-size x y w h) + (if (or (= x -11111) + (= y -11111) + (= w -1) + (= h -1)) + (let ([r (GetWindowRect hwnd)]) + (MoveWindow hwnd + (if (= x -11111) (RECT-left r) x) + (if (= y -11111) (RECT-top r) y) + (if (= w -1) (- (RECT-right r) (RECT-left r)) w) + (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) + #t)) + (MoveWindow hwnd x y w h #t)) + (unless (and (= w -1) (= h -1)) + (on-resized)) + (refresh)) + (define/public (move x y) + (set-size x y -1 -1)) + + (define/public (set-control-font font [hwnd hwnd]) + (unless theme-hfont + (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) + (let ([hfont (if font + (font->hfont font) + theme-hfont)]) + (SendMessageW hwnd WM_SETFONT (cast hfont _HFONT _LPARAM) 0))) + + (define/public (auto-size font label min-w min-h dw dh + [resize + (lambda (w h) (set-size -11111 -11111 w h))] + #:combine-width [combine-w max] + #:combine-height [combine-h max] + #:scale-w [scale-w 1] + #:scale-h [scale-h 1]) + (atomically + (unless measure-dc + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)]) + (set! measure-dc dc))) + (send measure-dc set-font (or font + (get-default-control-font))) + (let-values ([(w h d a) (let loop ([label label]) + (cond + [(null? label) (values 0 0 0 0)] + [(label . is-a? . bitmap%) + (values (send label get-width) + (send label get-height) + 0 + 0)] + [(pair? label) + (let-values ([(w1 h1 d1 a1) + (loop (car label))] + [(w2 h2 d2 a2) + (loop (cdr label))]) + (values (combine-w w1 w2) (combine-h h1 h2) + (combine-h d1 d1) (combine-h a1 a2)))] + [else + (send measure-dc get-text-extent label #f #t)]))] + [(->int) (lambda (v) (inexact->exact (floor v)))]) + (resize (->int (* scale-h (max (+ w dw) min-w))) + (->int (* scale-w (max (+ h dh) min-h))))))) + + (define/public (popup-menu m x y) + (let ([gx (box x)] + [gy (box y)]) + (client-to-screen gx gy) + (send m popup (unbox gx) (unbox gy) + hwnd + (lambda (thunk) (queue-window-event this thunk))))) + + (define/public (center a b) (void)) + + (define/public (get-parent) parent) + (define/public (is-frame?) #f) + + (define/public (refresh) (void)) + (define/public (on-resized) (void)) + + (define/public (screen-to-client x y) + (let ([p (make-POINT (unbox x) (unbox y))]) + (ScreenToClient (get-client-hwnd) p) + (set-box! x (POINT-x p)) + (set-box! y (POINT-y p)))) + (define/public (client-to-screen x y) + (let ([p (make-POINT (unbox x) (unbox y))]) + (ClientToScreen (get-client-hwnd) p) + (set-box! x (POINT-x p)) + (set-box! y (POINT-y p)))) + + (define/public (drag-accept-files on?) + (DragAcceptFiles (get-hwnd) on?)) + + (define/private (handle-drop-files wParam) + (let* ([hdrop (cast wParam _WPARAM _HDROP)] + [pt (DragQueryPoint hdrop)] + [count (DragQueryFileW hdrop #xFFFFFFFF #f 0)]) + (for ([i (in-range count)]) + (let* ([len (DragQueryFileW hdrop i #f 0)] + [b (malloc (add1 len) _int16)]) + (DragQueryFileW hdrop i b (add1 len)) + (let ([s (cast b _pointer _string/utf-16)]) + (queue-window-event this (lambda () (on-drop-file (string->path s))))))) + (DragFinish hdrop))) + + (define/public (on-drop-file p) (void)) + + (define/public (get-client-size w h) + (let ([r (GetClientRect (get-client-hwnd))]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + + (define/public (get-size w h) + (let ([r (GetWindowRect (get-client-hwnd))]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + + (define cursor-handle #f) + (define/public (set-cursor c) + (set! cursor-handle (and c (send (send c get-driver) get-handle))) + (when mouse-in? + (cursor-updated-here))) + + (define/public (cursor-updated-here) + (when mouse-in? + (send (get-top-frame) reset-cursor (get-arrow-cursor)))) + + (define/public (reset-cursor-in-child child default) + (send child reset-cursor (or cursor-handle default))) + + (define effective-cursor-handle #f) + (define/public (reset-cursor default) + (let ([c (or cursor-handle default)]) + (set! effective-cursor-handle c) + (SetCursor c))) + + (define/public (no-cursor-handle-here) + (send parent cursor-updated-here)) + + (define/public (set-focus [child-hwnd hwnd]) + (when (can-accept-focus?) + (set-top-focus this null child-hwnd))) + + (define/public (can-accept-focus?) + (child-can-accept-focus?)) + + (define/public (child-can-accept-focus?) + (and shown? + (send parent child-can-accept-focus?))) + + (define/public (set-top-focus win win-path hwnd) + (send parent set-top-focus win (cons this win-path) hwnd)) + (define/public (not-focus-child v) + (send parent not-focus-child v)) + + (define/public (gets-focus?) #f) + + (define/public (register-child child on?) + (void)) + (define/public (register-child-in-parent on?) + (when parent + (send parent register-child this on?))) + + (define/public (get-top-frame) + (send parent get-top-frame)) + + (define/private (do-key w msg wParam lParam is-char? is-up? default) + (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) + (if (and e + (if (definitely-wants-event? w msg wParam e) + (begin + (queue-window-event this (lambda () (dispatch-on-char/sync e))) + #t) + (constrained-reply eventspace + (lambda () (dispatch-on-char e #t)) + #t))) + 0 + (default w msg wParam lParam)))) + + (define/public (try-mouse w msg wParam lParam) + (cond + [(= msg WM_NCRBUTTONDOWN) + (do-mouse w msg #t 'right-down wParam lParam)] + [(= msg WM_NCRBUTTONUP) + (do-mouse w msg #t 'right-up wParam lParam)] + [(= msg WM_NCRBUTTONDBLCLK) + (do-mouse w msg #t 'right-down wParam lParam)] + [(= msg WM_NCMBUTTONDOWN) + (do-mouse w msg #t 'middle-down wParam lParam)] + [(= msg WM_NCMBUTTONUP) + (do-mouse w msg #t 'middle-up wParam lParam)] + [(= msg WM_NCMBUTTONDBLCLK) + (do-mouse w msg #t 'middle-down wParam lParam)] + [(= msg WM_NCLBUTTONDOWN) + (do-mouse w msg #t 'left-down wParam lParam)] + [(= msg WM_NCLBUTTONUP) + (do-mouse w msg #t 'left-up wParam lParam)] + [(= msg WM_NCLBUTTONDBLCLK) + (do-mouse w msg #t 'left-down wParam lParam)] + [(and (= msg WM_NCMOUSEMOVE) + (not (= wParam HTVSCROLL)) + (not (= wParam HTHSCROLL))) + (do-mouse w msg #t 'motion wParam lParam)] + [(= msg WM_RBUTTONDOWN) + (do-mouse w msg #f 'right-down wParam lParam)] + [(= msg WM_RBUTTONUP) + (do-mouse w msg #f 'right-up wParam lParam)] + [(= msg WM_RBUTTONDBLCLK) + (do-mouse w msg #f 'right-down wParam lParam)] + [(= msg WM_MBUTTONDOWN) + (do-mouse w msg #f 'middle-down wParam lParam)] + [(= msg WM_MBUTTONUP) + (do-mouse w msg #f 'middle-up wParam lParam)] + [(= msg WM_MBUTTONDBLCLK) + (do-mouse w msg #f 'middle-down wParam lParam)] + [(= msg WM_LBUTTONDOWN) + (do-mouse w msg #f 'left-down wParam lParam)] + [(= msg WM_LBUTTONUP) + (do-mouse w msg #f 'left-up wParam lParam)] + [(= msg WM_LBUTTONDBLCLK) + (do-mouse w msg #f 'left-down wParam lParam)] + [(= msg WM_MOUSEMOVE) + (do-mouse w msg #f 'motion wParam lParam)] + [(= msg WM_MOUSELEAVE) + (do-mouse w msg #f 'leave wParam lParam)] + [else #f])) + + (define/private (do-mouse control-hwnd msg nc? type wParam lParam) + (let ([x (LOWORD lParam)] + [y (HIWORD lParam)] + [flags (if nc? 0 wParam)] + [bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) + (let ([make-e + (lambda (type) + (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? flags MK_LBUTTON)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? flags MK_MBUTTON)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? flags MK_RBUTTON)])] + [x x] + [y y] + [shift-down (bit? flags MK_SHIFT)] + [control-down (bit? flags MK_CONTROL)] + [meta-down #f] + [alt-down #f] + [time-stamp 0] + [caps-down #f]))]) + (unless nc? + (when (wants-mouse-capture? control-hwnd) + (when (memq type '(left-down right-down middle-down)) + (SetCapture control-hwnd)) + (when (memq type '(left-up right-up middle-up)) + (ReleaseCapture)))) + (if mouse-in? + (if (send-child-leaves (lambda (type) (make-e type))) + (cursor-updated-here) + (if (send (get-top-frame) is-wait-cursor-on?) + (void (SetCursor (get-wait-cursor))) + (when effective-cursor-handle + (void (SetCursor effective-cursor-handle))))) + (let ([c (generate-mouse-ins this (lambda (type) (make-e type)))]) + (when c + (set! effective-cursor-handle c) + (void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?) + (get-wait-cursor) + c)))))) + (when (memq type '(left-down right-down middle-down)) + (set-focus)) + (handle-mouse-event control-hwnd msg wParam (make-e type))))) + + (define/private (handle-mouse-event w msg wParam e) + (if (definitely-wants-event? w msg wParam e) + (begin + (queue-window-event this (lambda () (dispatch-on-event/sync e))) + #t) + (constrained-reply eventspace + (lambda () (dispatch-on-event e #t)) + #t))) + + (define mouse-in? #f) + (define/public (generate-mouse-ins in-window mk) + (if mouse-in? + effective-cursor-handle + (begin + (set! mouse-in? #t) + (let ([parent-cursor (generate-parent-mouse-ins mk)]) + (handle-mouse-event (get-client-hwnd) 0 0 (mk 'enter)) + (let ([c (or cursor-handle parent-cursor)]) + (set! effective-cursor-handle c) + c))))) + + (define/public (generate-parent-mouse-ins mk) + (send parent generate-mouse-ins this mk)) + + (define/public (send-leaves mk) + (set! mouse-in? #f) + (let ([e (mk 'leave)]) + (if (eq? (current-thread) + (eventspace-handler-thread eventspace)) + (handle-mouse-event (get-client-hwnd) 0 0 e) + (queue-window-event this + (lambda () (dispatch-on-event/sync e)))))) + + (define/public (send-child-leaves mk) + #f) + + (define/public (wants-mouse-capture? control-hwnd) + #f) + + (define/public (definitely-wants-event? w msg wParam e) + #f) + + (define/public (dispatch-on-char/sync e) + (pre-event-refresh #t) + (dispatch-on-char e #f)) + (define/public (dispatch-on-char e just-pre?) + (cond + [(other-modal? this) #t] + [(call-pre-on-char this e) #t] + [just-pre? #f] + [else (when (is-enabled-to-root?) (on-char e)) #t])) + + (define/public (dispatch-on-event/sync e) + (pre-event-refresh #f) + (dispatch-on-event e #f)) + (define/public (dispatch-on-event e just-pre?) + (cond + [(other-modal? this) #t] + [(call-pre-on-event this e) #t] + [just-pre? #f] + [else (when (is-enabled-to-root?) (on-event e)) #t])) + + (define/public (call-pre-on-event w e) + (or (send parent call-pre-on-event w e) + (pre-on-event w e))) + (define/public (call-pre-on-char w e) + (or (send parent call-pre-on-char w e) + (pre-on-char w e))) + (define/public (pre-on-event w e) #f) + (define/public (pre-on-char w e) #f) + + (define/public (on-char e) (void)) + (define/public (on-event e) (void)) + + (define/private (pre-event-refresh key?) + ;; Since we break the connection between the + ;; Win32 queue and event handling, we + ;; re-sync the display in case a stream of + ;; events (e.g., key repeat) have a corresponding + ;; stream of screen updates. + (flush-display)) + + (define/public (get-dialog-level) (send parent get-dialog-level))) + +;; ---------------------------------------- + +(define (handle-copydata lParam) + (let* ([cd (cast lParam _LPARAM _COPYDATASTRUCT-pointer)] + [data (COPYDATASTRUCT-lpData cd)] + [guid-len (bytes-length GRACKET_GUID)] + [data-len (COPYDATASTRUCT-cbData cd)]) + (when (and (data-len + . > . + (+ guid-len (ctype-sizeof _DWORD))) + (bytes=? GRACKET_GUID + (scheme_make_sized_byte_string data + guid-len + 0)) + (bytes=? #"OPEN" + (scheme_make_sized_byte_string (ptr-add data guid-len) + 4 + 0))) + ;; The command line's argv (sans argv[0]) is + ;; expressed as a DWORD for the number of args, + ;; followed by each arg. Each arg is a DWORD + ;; for the number of chars and then the chars + (let ([args + (let ([count (ptr-ref data _DWORD 'abs (+ guid-len 4))]) + (let loop ([i 0] [delta (+ guid-len 4 (ctype-sizeof _DWORD))]) + (if (or (= i count) + ((+ delta (ctype-sizeof _DWORD)) . > . data-len)) + null + (let ([len (ptr-ref (ptr-add data delta) _DWORD)] + [delta (+ delta (ctype-sizeof _DWORD))]) + (if ((+ delta len) . > . data-len) + null + (let ([s (scheme_make_sized_byte_string + (ptr-add data delta) + len + 1)]) + (if (or (bytes=? s #"") + (regexp-match? #rx"\0" s)) + null + (cons (bytes->path s) + (loop (add1 i) (+ delta len))))))))))]) + (map queue-file-event args))))) + +;; ---------------------------------------- + +(define default-control-font #f) +(define (get-default-control-font) + (unless default-control-font + (set! default-control-font + (make-object font% + (get-theme-font-size) + (get-theme-font-face) + 'system + 'normal 'normal #f 'default + #t))) + default-control-font) + +(define (queue-window-event win thunk) + (queue-event (send win get-eventspace) thunk)) + +(define (queue-window-refresh-event win thunk) + (queue-refresh-event (send win get-eventspace) thunk)) + +(define (location->window x y) + (let ([hwnd (WindowFromPoint (make-POINT x y))]) + (let loop ([hwnd hwnd]) + (and hwnd + (or (let ([wx (any-hwnd->wx hwnd)]) + (and wx (send wx get-top-frame))) + (loop (GetParent hwnd))))))) + +(define (flush-display) + (atomically + (pre-event-sync #t))) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt new file mode 100644 index 00000000..880209d6 --- /dev/null +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -0,0 +1,309 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/alloc + racket/class + "../../lock.rkt" + "../common/utils.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "icons.rkt") + +(provide + (protect-out hInstance + DefWindowProcW + background-hbrush + set-hwnd-wx! + hwnd->wx + hwnd->ctlproc + any-hwnd->wx + CreateWindowExW + CreateWindowExW/control + CreateDialogIndirectParamW dialog-proc + clean-up-destroyed + MessageBoxW + _WndProc)) + +;; ---------------------------------------- +;; We use the "user data" field of an HWND to +;; store a weak pointer back to the Racket object. +;; The weak pointer must be wrapped in an immuable cell. +;; In addition, if we need to save a control's old +;; ctlproc, we put it in the same immutable cell. + +(define all-hwnds (make-hash)) + +;; call in atomic mode: +(define (register-hwnd! hwnd) + (hash-set! all-hwnds (cast hwnd _pointer _intptr) #t) + (let ([c (malloc-immobile-cell (vector #f #f #f))]) + (void (SetWindowLongPtrW hwnd GWLP_USERDATA c)))) + +(define (set-hwnd-wx! hwnd wx) + (let* ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)] + [v (ptr-ref c _racket)]) + (vector-set! v 0 (make-weak-box wx)))) + +(define (set-hwnd-ctlproc! hwnd save-ptr ctlproc) + (let* ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)] + [v (ptr-ref c _racket)]) + (vector-set! v 1 ctlproc) + (vector-set! v 2 save-ptr))) + +(define (hwnd->wx hwnd) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v + (let ([wb (vector-ref v 0)]) + (and wb + (weak-box-value wb)))))))) + +(define (any-hwnd->wx hwnd) + (and + (atomically (hash-ref all-hwnds (cast hwnd _pointer _intptr) #f)) + (let ([wx (hwnd->wx hwnd)]) + (and wx + (send wx is-hwnd? hwnd) + wx)))) + +(define (hwnd->ctlproc hwnd) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v (vector-ref v 1)))))) + +(define (hwnd->ctlproc-fptr hwnd) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v (vector-ref v 2)))))) + +;; call in atomic mode: +(define (can-unregister-hwnd? hwnd) + (hash-ref all-hwnds (cast hwnd _pointer _intptr) #f)) + +;; call in atomic mode: +(define (unregister-hwnd! hwnd) + (let ([c (GetWindowLongPtrW hwnd GWLP_USERDATA)]) + (when c + (free-immobile-cell c) + (SetWindowLongPtrW hwnd GWLP_USERDATA #f)) + (hash-remove! all-hwnds (cast hwnd _pointer _intptr)))) + +;; ---------------------------------------- + +(define-cstruct _INITCOMMONCONTROLSEX + ([dwSize _DWORD] + [dwICC _DWORD])) + +(define-comctl32 InitCommonControlsEx (_wfun _INITCOMMONCONTROLSEX-pointer -> _BOOL)) + +(void + (InitCommonControlsEx (make-INITCOMMONCONTROLSEX + (ctype-sizeof _INITCOMMONCONTROLSEX) + 0))) + +;; ---------------------------------------- + +(define _WndProc (_wfun #:atomic? #t #:keep (box null) + _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) + +(define (wind-proc w msg wparam lparam) + (if (= msg WM_DESTROY) + (begin + (unregister-hwnd! w) + (DefWindowProcW w msg wparam lparam)) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx wndproc w msg wparam lparam DefWindowProcW) + (DefWindowProcW w msg wparam lparam))))) + +(define wind-proc-ptr (function-ptr wind-proc _WndProc)) + +(define (control-proc w msg wParam lParam) + (let ([default-ctlproc (hwnd->ctlproc w)]) + (if (= msg WM_DESTROY) + (begin + (SetWindowLongPtrW w GWLP_WNDPROC (hwnd->ctlproc-fptr w)) + (unregister-hwnd! w) + (default-ctlproc w msg wParam lParam)) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx ctlproc w msg wParam lParam + (lambda (w msg wParam lParam) + (default-ctlproc w msg wParam lParam))) + (default-ctlproc w msg wParam lParam)))))) + +(define control_proc (function-ptr control-proc _WndProc)) + +(define (subclass-control hwnd) + (let* ([fptr (GetWindowLongPtrW hwnd GWLP_WNDPROC)] + [old-control-proc (function-ptr fptr _WndProc)]) + (set-hwnd-ctlproc! hwnd fptr old-control-proc) + (SetWindowLongPtrW hwnd GWLP_WNDPROC control_proc))) + + +(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) + +(define (dlgproc w msg wParam lParam) + (if (= msg WM_DESTROY) + (begin + (unregister-hwnd! w) + 0) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx wndproc w msg wParam lParam + (lambda (w msg wParam lParam) 0)) + 0)))) + +(define dialog-proc (function-ptr dlgproc _DialogProc)) + +;; ---------------------------------------- + +(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DestroyWindow)))) + +(define (maybe-destroy-window hwnd) + (atomically + (when (can-unregister-hwnd? hwnd) + (DestroyWindow hwnd)))) + +(define (clean-up-destroyed) + (free-remembered-now maybe-destroy-window)) + +(define-user32 _CreateWindowExW (_wfun _DWORD + _string/utf-16 + _string/utf-16 + _UDWORD + _int _int _int _int + _HWND _HMENU _HINSTANCE _pointer + -> _HWND) + #:c-id CreateWindowExW) + +(define (make-CreateWindowEx register!) + ((allocator remember-to-free-later) + (lambda (dwExStyle lpClassName lpWindowName dwStyle + x y nWidth nHeight + hWndParent hMenu hInstance lpParam) + (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle + x y nWidth nHeight + hWndParent hMenu hInstance lpParam)]) + (register! hwnd) + hwnd)))) + +(define CreateWindowExW (make-CreateWindowEx register-hwnd!)) +(define CreateWindowExW/control (make-CreateWindowEx (lambda (hwnd) + (register-hwnd! hwnd) + (subclass-control hwnd)))) + + +(define-user32 _CreateDialogIndirectParamW (_wfun _HINSTANCE + _pointer ; _DLGTEMPLATE-pointer + _HWND + _fpointer + _LPARAM + -> _HWND) + #:c-id CreateDialogIndirectParamW) + +(define CreateDialogIndirectParamW + ((allocator remember-to-free-later) + (lambda (hInstance lpTemplate hWndParent lpDialogFunc lParamInit) + (let ([hwnd (_CreateDialogIndirectParamW + hInstance lpTemplate hWndParent lpDialogFunc lParamInit)]) + (register-hwnd! hwnd) + hwnd)))) + +;; ---------------------------------------- + +(define-cstruct _WNDCLASS ([style _UINT] + [lpfnWndProc _fpointer] + [cbClsExtra _int] + [cbWndExtra _int] + [hInstace _HINSTANCE] + [hIcon _HICON] + [hCursor _HCURSOR] + [hbrBackground _HBRUSH] + [lpszMenuName _permanent-string/utf-16] + [lpszClassName _permanent-string/utf-16])) + +(define-user32 RegisterClassW (_wfun _WNDCLASS-pointer -> _ATOM)) +(define-kernel32 GetModuleHandleW (_wfun _pointer -> _HINSTANCE)) +(define-user32 LoadCursorW (_wfun _HINSTANCE _pointer -> _HCURSOR)) +(define-user32 LoadIconW (_wfun _HINSTANCE _string/utf-16 -> _HICON)) + +(define-user32 GetClassInfoW (_wfun _HINSTANCE _string/utf-16 (i : (_ptr o _WNDCLASS)) -> (r : _BOOL) + -> (if r i (failed 'GetClassInfoW)))) + +(define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define-user32 DefWindowProcW/raw _fpointer + #:c-id DefWindowProcW) + +#;(define-user32 PostQuitMessage (_wfun _int -> _void)) + +(define hInstance (GetModuleHandleW #f)) + +(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) + (cpointer-push-tag! p 'HBRUSH) + p)) + +(void (RegisterClassW (make-WNDCLASS CS_OWNDC + wind-proc-ptr + 0 + 0 + hInstance + (LoadIconW hInstance "WXSTD_FRAME") + #f + background-hbrush + #f ; menu + "PLTFrame"))) + +(void (RegisterClassW (make-WNDCLASS 0 ; using CS_OWNDC creates trouble when resizing? + wind-proc-ptr + 0 + 0 + hInstance + #f + #f + #f ; transparent + #f ; menu + "PLTCanvas"))) + +(void (RegisterClassW (make-WNDCLASS 0 + wind-proc-ptr + 0 + 0 + hInstance + #f + #f + background-hbrush + #f ; menu + "PLTPanel"))) + +(define controls-are-transparent? #f) + +(void (RegisterClassW (make-WNDCLASS 0 + wind-proc-ptr + 0 + 0 + hInstance + #f + #f + (if controls-are-transparent? + #f ; transparent + background-hbrush) + #f ; menu + "PLTTabPanel"))) + +(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int)) + +(define (register-no-cursor orig-name) + (let ([i (GetClassInfoW hInstance orig-name)]) + (set-WNDCLASS-lpszClassName! i (string-append "PLT" orig-name)) + (set-WNDCLASS-hCursor! i #f) + (void (RegisterClassW i)))) + +(register-no-cursor "BUTTON") +(register-no-cursor "STATIC") +(register-no-cursor "LISTBOX") +(register-no-cursor "COMBOBOX") +(register-no-cursor "msctls_trackbar32") +(register-no-cursor "msctls_progress32") +(register-no-cursor "SysTabControl32") diff --git a/collects/mred/private/wxcanvas.rkt b/collects/mred/private/wxcanvas.rkt index 84655732..8d8591b3 100644 --- a/collects/mred/private/wxcanvas.rkt +++ b/collects/mred/private/wxcanvas.rkt @@ -23,14 +23,16 @@ [do-on-scroll (lambda (e) (super on-scroll e))] [do-on-paint (lambda () (super on-paint))]) (private-field - [tabable? default-tabable?]) + [tabable? default-tabable?] + [on-popup-callback void]) (public [get-tab-focus (lambda () tabable?)] [set-tab-focus (lambda (v) (set! tabable? v))] [on-tab-in (lambda () (let ([mred (wx->mred this)]) (when mred - (send mred on-tab-in))))]) + (send mred on-tab-in))))] + [set-on-popup (lambda (proc) (set! on-popup-callback proc))]) (override [gets-focus? (lambda () tabable?)] [handles-key-code @@ -61,25 +63,16 @@ (lambda (e) (let ([mred (get-mred)]) (if mred - ;; Delay callback for Windows scrollbar - ;; and Windows/Mac trampoiline - (queue-window-callback - this - (lambda () (send mred on-scroll e))) + (send mred on-scroll e) (as-exit (lambda () (super on-scroll e)))))))] [on-paint (entry-point (lambda () (let ([mred (get-mred)]) (if mred - (if (and (eq? 'windows (system-type)) - (not (eq? (wx:current-eventspace) - (send (get-top-level) get-eventspace)))) - ;; Windows circumvented the event queue; delay - (queue-window-callback - this - (lambda () (clear-and-on-paint mred))) - (as-exit (lambda () (clear-and-on-paint mred)))) - (as-exit (lambda () (clear-margins) (super on-paint)))))))]) + (as-exit (lambda () (clear-and-on-paint mred))) + (as-exit (lambda () (clear-margins) (super on-paint)))))))] + ;; for 'combo canvases: + [on-popup (lambda () (on-popup-callback))]) (sequence (apply super-init mred proxy args)))) (define wx-canvas% @@ -226,12 +219,9 @@ #t (make-editor-canvas% (make-control% wx:editor-canvas% 0 0 #t #t))) - (inherit editor-canvas-on-scroll) + (inherit editor-canvas-on-scroll + set-no-expose-focus) (define/override (on-scroll e) - (if (or (eq? 'windows (system-type)) - (eq? 'macosx (system-type))) - (queue-window-callback - this - (lambda () (editor-canvas-on-scroll))) - (editor-canvas-on-scroll))) - (super-new)))) + (editor-canvas-on-scroll)) + (super-new) + #;(set-no-expose-focus)))) diff --git a/collects/mred/private/wxitem.rkt b/collects/mred/private/wxitem.rkt index fe6497cb..0f84b39c 100644 --- a/collects/mred/private/wxitem.rkt +++ b/collects/mred/private/wxitem.rkt @@ -1,9 +1,8 @@ -(module wxitem mzscheme +(module wxitem racket/base (require mzlib/class mzlib/class100 mzlib/etc - mzlib/file - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "helper.ss" "const.ss" @@ -11,17 +10,12 @@ "check.ss" "wxwindow.ss") - (provide (protect make-item% - make-control% - make-simple-control% - wx-button% - wx-check-box% - wx-choice% - wx-message% - wx-gauge% - wx-list-box% - wx-radio-box% - wx-slider%)) + (provide (protect-out make-item% + make-control% + make-simple-control% + wx-button% + wx-check-box% + wx-message%)) ;; make-item%: creates items which are suitable for placing into ;; containers. @@ -67,8 +61,7 @@ (super set-size x y width height)))]) (public - [is-enabled? - (lambda () enabled?)]) + [is-enabled? (lambda () enabled?)]) (private-field ;; Store minimum size of item. @@ -213,10 +206,8 @@ (apply super-init args) (send (get-parent) set-item-cursor 0 0)))) - (define (make-simple-control% item%) - (make-control% item% - const-default-x-margin const-default-y-margin - #f #f)) + (define (make-simple-control% item% [x-m const-default-x-margin] [y-m const-default-y-margin]) + (make-control% item% x-m y-m #f #f)) (define wx-button% (make-window-glue% (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font) @@ -246,162 +237,8 @@ (set-value (not (get-value))) (command (make-object wx:control-event% 'check-box)))))]) (sequence (super-init mred proxy style parent cb label x y w h (cons 'deleted style) font)))) - (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) - (override - [handles-key-code - (lambda (x alpha? meta?) - (or (memq x '(up down)) - (and alpha? (not meta?))))]) - (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font)))) + (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font) (override [gets-focus? (lambda () #f)]) - (sequence (super-init mred proxy style parent label x y (cons 'deleted style) font)))) - - (define wx-gauge% - (make-window-glue% - (class100 (make-control% wx:gauge% - const-default-x-margin const-default-y-margin - #f #f) - (parent label range style font) - (inherit get-client-size get-width get-height set-size - stretchable-in-x stretchable-in-y set-min-height set-min-width - get-parent) - (override [gets-focus? (lambda () #f)]) - (private-field - ;; # pixels per unit of value. - [pixels-per-value 1]) - (sequence - (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font) - - (let-values ([(client-width client-height) (get-two-int-values - (lambda (a b) (get-client-size a b)))]) - (let ([delta-w (- (get-width) client-width)] - [delta-h (- (get-height) client-height)] - [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] - [horizontal? (memq 'horizontal style)]) - (set-min-width (if horizontal? - (let ([cw (min const-max-gauge-length - (* range pixels-per-value))]) - (max (if vertical-labels? - cw - (+ cw delta-w)) - (get-width))) - ;; client-height is the default - ;; dimension in the minor direction. - (+ client-width delta-w))) - (set-min-height (if horizontal? - (+ client-height delta-h) - (let ([ch (min const-max-gauge-length - (* range pixels-per-value))]) - (max (if vertical-labels? - (+ ch delta-h) - ch) - (get-height))))))) - - (if (memq 'horizontal style) - (begin - (stretchable-in-x #t) - (stretchable-in-y #f)) - (begin - (stretchable-in-x #f) - (stretchable-in-y #t))))))) - - (define list-box-wheel-step #f) - - (define wx-list-box% - (make-window-glue% - (class100 (make-control% wx:list-box% - const-default-x-margin const-default-y-margin - #t #t) (parent cb label kind x y w h choices style font label-font) - (inherit get-first-item - set-first-visible-item) - (private - [scroll (lambda (dir) - (unless list-box-wheel-step - (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3))) - (unless (and (number? list-box-wheel-step) - (exact? list-box-wheel-step) - (integer? list-box-wheel-step) - (<= 1 list-box-wheel-step 100)) - (set! list-box-wheel-step 3))) - (let ([top (get-first-item)]) - (set-first-visible-item - (max 0 (+ top (* list-box-wheel-step dir))))))]) - (override - [handles-key-code (lambda (x alpha? meta?) - (case x - [(up down) #t] - [else (and alpha? (not meta?))]))] - [pre-on-char (lambda (w e) - (or (super pre-on-char w e) - (case (send e get-key-code) - [(wheel-up) (scroll -1) #t] - [(wheel-down) (scroll 1) #t] - [else #f])))]) - (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font))))) - - (define wx-radio-box% - (make-window-glue% - (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font) - (inherit number orig-enable set-selection command) - (override - [enable - (case-lambda - [(on?) (super enable on?)] - [(which on?) (when (< -1 which (number)) - (vector-set! enable-vector which (and on? #t)) - (orig-enable which on?))])] - [is-enabled? - (case-lambda - [() (super is-enabled?)] - [(which) (and (< -1 which (number)) - (vector-ref enable-vector which))])]) - - (private-field [is-vertical? (memq 'vertical style)]) - (public - [vertical? (lambda () is-vertical?)] - [char-to-button (lambda (i) - (as-exit - (lambda () - (set-selection i) - (command (make-object wx:control-event% 'radio-box)))))]) - - (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font)) - - (private-field [enable-vector (make-vector (number) #t)])))) - - (define wx-slider% - (make-window-glue% - (class100 (make-control% wx:slider% - const-default-x-margin const-default-y-margin - #f #f) - (parent func label value min-val max-val style font) - (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y - get-client-size get-width get-height get-parent) - (private-field - ;; # pixels per possible setting. - [pixels-per-value 3]) - ;; 3 is good because with horizontal sliders under Xt, with 1 or 2 - ;; pixels per value, the thumb is too small to display the number, - ;; which looks bad. - - (sequence - (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font) - - (let-values ([(client-w client-h) (get-two-int-values (lambda (a b) - (get-client-size a b)))]) - (let* ([horizontal? (memq 'horizontal style)] - [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] - [range (+ (* pixels-per-value (add1 (- max-val min-val))) - (cond - [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)] - [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)] - [else 0]))]) - ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v))) - (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height)))) - (min const-max-gauge-length range))) - (stretchable-in-x horizontal?) - (stretchable-in-y (not horizontal?)))))))) - - ) + (sequence (super-init mred proxy style parent label x y (cons 'deleted style) font))))) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt new file mode 100644 index 00000000..9b14bcac --- /dev/null +++ b/collects/mred/private/wxlitem.rkt @@ -0,0 +1,386 @@ +(module wxlitem mzscheme + (require mzlib/class + mzlib/class100 + mzlib/file + (only racket/base remq) + (prefix wx: "kernel.ss") + "lock.ss" + "helper.ss" + "const.ss" + "wx.ss" + "check.ss" + "wxwindow.ss" + "wxitem.ss" + "wxpanel.ss") + + (provide (protect wx-choice% + wx-list-box% + wx-radio-box% + wx-gauge% + wx-slider%)) + + ;; ---------------------------------------- + + (define (is-horiz? style parent) + (cond + [(memq 'vertical-label style) #f] + [(memq 'horizontal-label style) #t] + [else (eq? (send (send parent get-window) get-label-position) 'horizontal)])) + + (define (make-sub horiz? proxy this ha va) + (if horiz? + (begin + (send this alignment ha va) + this) + (let ([p (make-object wx-vertical-pane% #f proxy this null #f)]) + (send p skip-subwindow-events? #t) + (send (send p area-parent) add-child p) + (send p alignment ha va) + p))) + + (define (make-label label proxy p font) + (and label + (let ([l (make-object wx-message% #f proxy p label -1 -1 null font)]) + (send l skip-subwindow-events? #t) + l))) + + (define (filter-style style) + (remq 'deleted style)) + + (define-syntax-rule (bounce c (m arg ...) ...) + (begin + (define/public m (lambda (arg ...) (send c m arg ...))) + ...)) + + ;; ---------------------------------------- + + (define wx-label-panel% + (class wx-control-horizontal-panel% + (init proxy parent label style font halign valign) + (inherit area-parent) + (define c #f) + + (define/override (enable on?) (if c (send c enable on?) (void))) + (define/override (is-enabled?) (if c (send c is-enabled?) #t)) + (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t)) + + (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f) + (unless (memq 'deleted style) + (send (area-parent) add-child this)) + (define horiz? (is-horiz? style parent)) + (define p (make-sub horiz? proxy this (if horiz? 'left halign) valign)) + + (define l (make-label label proxy p font)) + (define/public (set-label s) (when l (send l set-label s))) + (define/public (get-label) (and l (send l get-label))) + + (define/public (get-p) p) + (define/public (set-c v sx? sy?) + (set! c v) + (send c stretchable-in-x sx?) + (send c stretchable-in-y sy?) + (send c skip-subwindow-events? #t)))) + + ;; ---------------------------------------- + + (define wx-internal-choice% + (class100 (make-window-glue% (make-simple-control% wx:choice% 0 0)) (mred proxy parent cb label x y w h choices style font) + (override + [handles-key-code + (lambda (x alpha? meta?) + (or (memq x '(up down)) + (and alpha? (not meta?))))]) + (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font)))) + + (define wx-choice% + (class wx-label-panel% + (init mred proxy parent cb label x y w h choices style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'left 'center) + + (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices + (filter-style style) font)) + (set-c c #t #f) + + (bounce + c + (set-selection i) + (get-selection) + (number) + (clear) + (append lbl)) + + (stretchable-in-y #f) + (stretchable-in-x #f))) + + ;; ---------------------------------------- + + (define list-box-wheel-step #f) + + (define wx-internal-list-box% + (make-window-glue% + (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font) + (inherit get-first-item + set-first-visible-item) + (private + [scroll (lambda (dir) + (unless list-box-wheel-step + (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3))) + (unless (and (number? list-box-wheel-step) + (exact? list-box-wheel-step) + (integer? list-box-wheel-step) + (<= 1 list-box-wheel-step 100)) + (set! list-box-wheel-step 3))) + (let ([top (get-first-item)]) + (set-first-visible-item + (max 0 (+ top (* list-box-wheel-step dir))))))]) + (override + [handles-key-code (lambda (x alpha? meta?) + (case x + [(up down) #t] + [else (and alpha? (not meta?))]))] + [pre-on-char (lambda (w e) + (or (super pre-on-char w e) + (case (send e get-key-code) + [(wheel-up) (scroll -1) #t] + [(wheel-down) (scroll 1) #t] + [else #f])))]) + (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font))))) + + (define wx-list-box% + (class wx-label-panel% + (init mred proxy parent cb label kind x y w h choices style font label-font) + (inherit get-p set-c) + + (super-init proxy parent label style font 'left 'top) + + (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices + (filter-style style) font label-font)) + (set-c c #t #t) + + (bounce + c + (get-label-font) + (set-string i s) + (set-selection i) + (get-selection) + (get-selections) + (visible-range) + (get-first-item) + (number-of-visible-items) + (set-first-visible-item i) + (number) + (get-row n) + (set-data i v) + (get-data i) + (selected? i) + (delete i) + (clear) + (set choices) + (reset)) + (define/public select + (case-lambda + [(i) (send c select i)] + [(i on?) (send c select i on?)] + [(i on? extend?) (send c select i on? extend?)])) + (define/public append + (case-lambda + [(s) (send c append s)] + [(s v) (send c append s v)])))) + + ;; ---------------------------------------- + + (define wx-internal-radio-box% + (make-window-glue% + (class100 (make-simple-control% wx:radio-box% 0 0) (parent cb label x y w h choices major style font) + (inherit number orig-enable set-selection command) + (override + [enable + (case-lambda + [(on?) (super enable on?)] + [(which on?) (when (< -1 which (number)) + (vector-set! enable-vector which (and on? #t)) + (orig-enable which on?))])] + [is-enabled? + (case-lambda + [() (super is-enabled?)] + [(which) (and (< -1 which (number)) + (vector-ref enable-vector which))])]) + + (private-field [is-vertical? (memq 'vertical style)]) + (public + [vertical? (lambda () is-vertical?)] + [char-to-button (lambda (i) + (as-exit + (lambda () + (set-selection i) + (command (make-object wx:control-event% 'radio-box)))))]) + + (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font)) + + (private-field [enable-vector (make-vector (number) #t)])))) + + (define wx-radio-box% + (class wx-label-panel% + (init mred proxy parent cb label x y w h choices major style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'left 'center) + + (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices + major (filter-style style) font)) + (set-c c #t #t) + + (define enable-vector (make-vector (length choices) #t)) + + (define/override enable + (case-lambda + [(on?) (super enable on?)] + [(i on?) + (when (< -1 i (vector-length enable-vector)) + (vector-set! enable-vector i on?) + (send c enable-button i on?))])) + + (define/override is-enabled? + (case-lambda + [() (super is-enabled?)] + [(which) (and (< -1 which (vector-length enable-vector)) + (vector-ref enable-vector which))])) + + (bounce + c + (button-focus i) + (set-selection i) + (get-selection)) + (stretchable-in-y #f) + (stretchable-in-x #f))) + + ;; ---------------------------------------- + + (define wx-internal-gauge% + (make-window-glue% + (class100 (make-control% wx:gauge% 0 0 #f #f) + (parent label range style font) + (inherit get-client-size get-width get-height set-size + stretchable-in-x stretchable-in-y set-min-height set-min-width + get-parent) + (override [gets-focus? (lambda () #f)]) + (private-field + ;; # pixels per unit of value. + [pixels-per-value 1]) + (sequence + (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font) + + (let-values ([(client-width client-height) (get-two-int-values + (lambda (a b) (get-client-size a b)))]) + (let ([delta-w (- (get-width) client-width)] + [delta-h (- (get-height) client-height)] + [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] + [horizontal? (memq 'horizontal style)]) + (set-min-width (if horizontal? + (let ([cw (min const-max-gauge-length + (* range pixels-per-value))]) + (max (if vertical-labels? + cw + (+ cw delta-w)) + (get-width))) + ;; client-height is the default + ;; dimension in the minor direction. + (+ client-width delta-w))) + (set-min-height (if horizontal? + (+ client-height delta-h) + (let ([ch (min const-max-gauge-length + (* range pixels-per-value))]) + (max (if vertical-labels? + (+ ch delta-h) + ch) + (get-height))))))) + + (if (memq 'horizontal style) + (begin + (stretchable-in-x #t) + (stretchable-in-y #f)) + (begin + (stretchable-in-x #f) + (stretchable-in-y #t))))))) + + (define wx-gauge% + (class wx-label-panel% + (init mred proxy parent label range style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'center 'center) + + (define c (make-object wx-internal-gauge% mred proxy (get-p) label range + (filter-style style) font)) + (set-c c + (memq 'horizontal style) + (memq 'vertical style)) + + (bounce + c + (get-range) + (set-range rng) + (get-value) + (set-value v)) + (let ([h? (and (memq 'horizontal style) #t)]) + (stretchable-in-x h?) + (stretchable-in-y (not h?))))) + + ;; ---------------------------------------- + + (define wx-internal-slider% + (make-window-glue% + (class100 (make-control% wx:slider% 0 0 #f #f) + (parent func label value min-val max-val style font) + (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y + get-client-size get-width get-height get-parent) + (private-field + ;; # pixels per possible setting. + [pixels-per-value 3]) + ;; 3 is good because with horizontal sliders under Xt, with 1 or 2 + ;; pixels per value, the thumb is too small to display the number, + ;; which looks bad. + + (sequence + (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font) + + (let-values ([(client-w client-h) (get-two-int-values (lambda (a b) + (get-client-size a b)))]) + (let* ([horizontal? (memq 'horizontal style)] + [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)] + [range (+ (* pixels-per-value (add1 (- max-val min-val))) + (cond + [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)] + [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)] + [else 0]))]) + ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v))) + (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height)))) + (min const-max-gauge-length range))) + (stretchable-in-x horizontal?) + (stretchable-in-y (not horizontal?)))))))) + + (define wx-slider% + (class wx-label-panel% + (init mred proxy parent func label value min-val max-val style font) + (inherit stretchable-in-y stretchable-in-x get-p set-c) + + (super-init proxy parent label style font 'center 'center) + + (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val + (filter-style style) font)) + + (set-c c + (memq 'horizontal style) + (memq 'vertical style)) + + (bounce + c + (get-value) + (set-value v)) + (let ([h? (and (memq 'horizontal style) #t)]) + (stretchable-in-x h?) + (stretchable-in-y (not h?))))) + +) diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt index fddd00c0..55542210 100644 --- a/collects/mred/private/wxme/editor-canvas.rkt +++ b/collects/mred/private/wxme/editor-canvas.rkt @@ -159,7 +159,9 @@ get-scroll-range set-scroll-range is-shown-to-root? show-scrollbars - set-focus) + set-focus + begin-refresh-sequence + end-refresh-sequence) (define blink-timer #f) (define noloop? #f) @@ -357,18 +359,10 @@ (define/override (on-set-focus) (super on-set-focus) - (if (eq? 'windows (system-type)) - (queue-window-callback - this - (lambda () (on-focus #t))) - (on-focus #t))) + (on-focus #t)) (define/override (on-kill-focus) (super on-kill-focus) - (if (eq? 'windows (system-type)) - (queue-window-callback - this - (lambda () (on-focus #f))) - (on-focus #f))) + (on-focus #f)) (define/public (is-focus-on?) focuson?) @@ -391,29 +385,35 @@ (set! last-x x) (set! last-y y) + #; (when (and (eq? 'windows (system-type)) (not focuson?) (send event button-down?)) (set-focus) (on-focus #t)) - - (when (and media - (not (send media get-printing))) - (using-admin - (when media - (set-custom-cursor - (send media adjust-cursor event))) - (when media - (send media on-event event)))) - - (when (send event dragging?) - (let-boxes ([cw 0] - [ch 0]) - (get-client-size cw ch) - (when (or (x . < . 0) - (y . < . 0) - (x . > . cw) - (y . > . ch)) + + (let ([out-of-client? + (let-boxes ([cw 0] + [ch 0]) + (get-client-size cw ch) + (or (x . < . 0) + (y . < . 0) + (x . > . cw) + (y . > . ch)))]) + + (when (and media + (not (send media get-printing))) + (using-admin + (when media + (set-custom-cursor + (and (or (not out-of-client?) + (send event dragging?)) + (send media adjust-cursor event)))) + (when media + (send media on-event event)))) + + (when (send event dragging?) + (when out-of-client? ;; Dragging outside the canvas: auto-generate more events because the buffer ;; is probably scrolling. But make sure we're shown. (when (is-shown-to-root?) @@ -445,13 +445,14 @@ (let-boxes ([x 0] [y 0]) (get-scroll x y) - (let ([y (max (+ y + (let ([old-y y] + [y (max (+ y (* wheel-amt (if (eq? code 'wheel-up) -1 1))) 0)]) - (do-scroll x y #t))))] + (do-scroll x y #t x old-y))))] [else (when (and media (not (send media get-printing))) (using-admin @@ -495,7 +496,7 @@ (when (not (send media get-printing)) (let-boxes ([x 0][y 0][w 0][h 0]) (get-view x y w h) - (redraw x y w h))) + (redraw x y w h #f))) (let ([bg (get-canvas-background)]) (when bg (let ([adc (get-dc)]) @@ -543,28 +544,31 @@ (let-boxes ([x 0] [y 0]) (get-scroll x y) - (when fx - (set-box! fx (- (* x hpixels-per-scroll) xmargin))) - (when fy - (if (and media - (or (positive? y) - scroll-bottom-based?)) - (let ([v (- (if (send media locked-for-read?) - 0.0 - (send media scroll-line-location (+ y scroll-offset))) - ymargin)]) - (set-box! fy v) - (when (and scroll-bottom-based? - (or (positive? scroll-height) - scroll-to-last?)) - (let-boxes ([w 0] [h 0]) - (get-client-size w h) - (let ([h (max (- h (* 2 ymargin)) - 0)]) - (set-box! fy (- (unbox fy) h)))))) - (set-box! fy (- ymargin)))))) + (convert-scroll-to-location x y fx fy))) (get-dc)) + (define/private (convert-scroll-to-location x y fx fy) + (when fx + (set-box! fx (- (* x hpixels-per-scroll) xmargin))) + (when fy + (if (and media + (or (positive? y) + scroll-bottom-based?)) + (let ([v (- (if (send media locked-for-read?) + 0.0 + (send media scroll-line-location (+ y scroll-offset))) + ymargin)]) + (set-box! fy v) + (when (and scroll-bottom-based? + (or (positive? scroll-height) + scroll-to-last?)) + (let-boxes ([w 0] [h 0]) + (get-client-size w h) + (let ([h (max (- h (* 2 ymargin)) + 0)]) + (set-box! fy (- (unbox fy) h)))))) + (set-box! fy (- ymargin))))) + (define/public (get-view fx fy fw fh [unused-full? #f]) (let ([w (box 0)] [h (box 0)]) @@ -579,10 +583,21 @@ (when fw (set-box! fw (max 0 (- (unbox w) (* 2 xmargin))))))) - (define/public (redraw localx localy fw fh) + (define/public (redraw localx localy fw fh clear?) (when (and media (not (send media get-printing))) (begin-refresh-sequence) + (when clear? + (let ([bg (get-canvas-background)]) + (when bg + (let ([adc (get-dc)]) + (let ([b (send adc get-brush)] + [p (send adc get-pen)]) + (send adc set-brush bg 'solid) + (send adc set-pen bg 1 'transparent) + (send adc draw-rectangle localx localy fw fh) + (send adc set-brush b) + (send adc set-pen p)))))) (let ([x (box 0)] [y (box 0)] [w (box 0)] @@ -699,7 +714,7 @@ (send hscroll set-value sx)) (when vscroll (send vscroll set-value sy)) - (do-scroll sx sy refresh?) + (do-scroll sx sy refresh? cx cy) #t) #f))))))))) @@ -793,8 +808,10 @@ (values 0 0 0 0 1 1) (when (not media) (let ([dc (get-dc)]) - (send dc set-background (get-canvas-background)) - (send dc clear)))))]) + (let ([bg (get-canvas-background)]) + (when bg + (send dc set-background bg) + (send dc clear)))))))]) (if (not (and (= scroll-width hnum-scrolls) (= scroll-height vnum-scrolls) @@ -868,7 +885,7 @@ retval))))))) - (define/private (do-scroll x y refresh?) + (define/private (do-scroll x y refresh? old-x old-y) (let ([savenoloop? noloop?]) (set! noloop? #t) @@ -883,8 +900,45 @@ (set-scroll-pos 'vertical (->long (min y scroll-height))))) (set! noloop? savenoloop?) - - (when refresh? (repaint)))) + + (when refresh? + (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Windows + (not need-refresh?) + (not lazy-refresh?) + (get-canvas-background) + (= x old-x)) ; could handle horizontal scrolling in the future + (let-boxes ([fx 0] + [old-fy 0] + [new-fy 0]) + (begin + (convert-scroll-to-location x y fx new-fy) + (convert-scroll-to-location old-x old-y #f old-fy)) + (let-boxes ([vx 0][vy 0][vw 0][vh 0]) + (get-view vx vy vw vh) ; editor coords + (cond + [(and (new-fy . < . old-fy) + (old-fy . < . (+ new-fy vh))) + (let ([dc (get-dc)]) + (send dc copy + xmargin ymargin + vw (- (+ new-fy vh) old-fy) + xmargin (+ ymargin (- old-fy new-fy))) + (redraw xmargin ymargin + vw (- old-fy new-fy) + #t))] + [(and (old-fy . < . new-fy) + (new-fy . < . (+ old-fy vh))) + (let ([dc (get-dc)]) + (send dc copy + xmargin (+ ymargin (- new-fy old-fy)) + vw (- (+ old-fy vh) new-fy) + xmargin ymargin) + (let ([d (- (+ old-fy vh) new-fy)]) + (redraw xmargin (+ ymargin d) + vw (- vh d) + #t)))] + [else (repaint)]))) + (repaint))))) (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void)) @@ -1118,7 +1172,7 @@ [is-shown? (if (not (send canvas get-canvas-background)) (send canvas repaint) - (send canvas redraw localx localy w h))])))) + (send canvas redraw localx localy w h #f))])))) (define/override (resized update?) (all-in-chain (lambda (a) (send a do-resized update?)))) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 63657249..0c74ec30 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -284,7 +284,7 @@ (def/override (draw [dc<%> dc] [real? x] [real? y] [real? left] [real? top] [real? right] [real? bottom] - [real? dx] [real? dy] [symbol? caret]) + [real? dx] [real? dy] [caret-status? caret]) (send my-admin with-dc dc x y @@ -320,6 +320,7 @@ (let ([bg-color (cond + [(pair? caret) #f] [(not use-style-bg?) (make-object color% 255 255 255)] [(send s-style get-transparent-text-backing) @@ -357,34 +358,40 @@ caret bg-color)) (when with-border? - (let* ([l (+ orig-x left-inset)] - [t (+ orig-y top-inset)] - [r (+ l w left-margin right-margin - (- (+ left-inset right-inset)) - -1)] - [b (+ t h top-margin bottom-margin - (- (+ top-inset bottom-inset)) - -1)]) - (let ([ml (max (min l right) left)] - [mr (max (min r right) left)] - [mt (max (min t bottom) top)] - [mb (max (min b bottom) top)]) - (when (and (l . >= . left) - (l . < . right) - (mt . < . mb)) - (send dc draw-line l mt l mb)) - (when (and (r . >= . left) - (r . < . right) - (mt . < . mb)) - (send dc draw-line r mt r mb)) - (when (and (t . >= . top) - (t . < . bottom) - (ml . < . mr)) - (send dc draw-line ml t mr t)) - (when (and (b . >= . top) - (b . < . bottom) - (ml . < . mr)) - (send dc draw-line ml b mr b))))))))))) + (let ([pen (send dc get-pen)]) + (when (and (pair? caret) + selected-text-color) + (send dc set-pen selected-text-color 1 'solid)) + (let* ([l (+ orig-x left-inset)] + [t (+ orig-y top-inset)] + [r (+ l w left-margin right-margin + (- (+ left-inset right-inset)) + -1)] + [b (+ t h top-margin bottom-margin + (- (+ top-inset bottom-inset)) + -1)]) + (let ([ml (max (min l right) left)] + [mr (max (min r right) left)] + [mt (max (min t bottom) top)] + [mb (max (min b bottom) top)]) + (when (and (l . >= . left) + (l . < . right) + (mt . < . mb)) + (send dc draw-line l mt l mb)) + (when (and (r . >= . left) + (r . < . right) + (mt . < . mb)) + (send dc draw-line r mt r mb)) + (when (and (t . >= . top) + (t . < . bottom) + (ml . < . mr)) + (send dc draw-line ml t mr t)) + (when (and (b . >= . top) + (b . < . bottom) + (ml . < . mr)) + (send dc draw-line ml b mr b)))) + (when (pair? caret) + (send dc set-pen pen)))))))))) (def/override (copy) (let* ([mb (and editor diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index bf99cab2..4cffb161 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -63,7 +63,8 @@ (define/public (set-last-used v) (set! last-used v)) (define/public (ready-offscreen width height) - (if (or (width . > . RIDICULOUS-SIZE) + (if (or #t ; disable on all platforms + (width . > . RIDICULOUS-SIZE) (height . > . RIDICULOUS-SIZE) (eq? (system-type) 'macosx)) #f @@ -505,7 +506,7 @@ snip)) (def/public (insert-image [(make-or-false path-string?) [filename #f]] - [symbol? [type 'unknown]] + [image-type? [type 'unknown/alpha]] [any? [relative? #f]] [any? [inline-img? #t]]) (let ([filename (or filename @@ -517,7 +518,7 @@ (insert snip))))) (def/public (on-new-image-snip [path-string? filename] - [symbol? type] + [image-type? type] [any? relative?] [any? inline-img?]) (make-object image-snip% filename type relative? inline-img?)) @@ -743,9 +744,7 @@ [any? [parent #f]] ; checked in ../editor.ss [bool? [force-page-bbox? #t]] [bool? [as-eps? #f]]) - (let ([ps? (case (system-type) - [(macosx windows) (eq? output-mode 'postscript)] - [else #t])] + (let ([ps? (eq? output-mode 'postscript)] [parent (or parent (extract-parent))]) (cond @@ -1265,14 +1264,14 @@ #f)) (def/public (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [caret-status? show-caret] [(make-or-false color%) bg-color]) (void)) (def/public (on-paint [any? pre?] [dc<%> dc] [real? l] [real? t] [real? r] [real? b] [real? dx] [real? dy] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret]) + [caret-status? show-caret]) (void)) (def/public (can-save-file? [path-string? filename] diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 4c07fd66..4bb1e8d7 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -34,8 +34,9 @@ (define black-brush (send the-brush-list find-or-create-brush "black" 'xor)) (define white-brush (send the-brush-list find-or-create-brush "white" 'solid)) (define invisi-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) -(define rb-brush (send the-brush-list find-or-create-brush "black" 'transparent)) -(define rb-pen (send the-pen-list find-or-create-pen "black" 1 'xor-dot)) +(define invisi-brush (send the-brush-list find-or-create-brush "black" 'transparent)) +(define rb-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'xor-dot)) +(define rb-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) (define arrow (make-object cursor% 'arrow)) @@ -122,6 +123,11 @@ (define dragging? #f) (define rubberband? #f) + (define rb-x 0.0) + (define rb-y 0.0) + (define rb-w 0.0) + (define rb-h 0.0) + (define need-resize? #f) (define resizing #f) ; a snip @@ -137,8 +143,10 @@ (define update-left 0.0) (define update-right 0.0) + (define update-right-end #f) (define update-top 0.0) (define update-bottom 0.0) + (define update-bottom-end #f) (define update-nonempty? #f) (define no-implicit-update? #f) @@ -165,7 +173,7 @@ ;; ---------------------------------------- - (define/private (rubber-band x y w h) + (define/private (rubber-band-update x y w h) (when (and s-admin (not (zero? w)) (not (zero? h))) @@ -190,22 +198,11 @@ [b (min b (+ vy vh))]) (unless (or (x . >= . r) (y . >= . b)) - (let-boxes ([dc #f] - [dx 0.0] - [dy 0.0]) - (set-box! dc (send s-admin get-dc dx dy)) - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-pen rb-pen) - (send dc set-brush rb-brush) - - (send dc draw-rectangle - (- x dx) (- y dy) - (- r x) - (- b y)) - - (send dc set-pen old-pen) - (send dc set-brush old-brush)))))))))) + (set! rb-x x) + (set! rb-y y) + (set! rb-w (- r x)) + (set! rb-h (- b y)) + (update rb-x rb-y rb-w rb-h)))))))) (def/override (adjust-cursor [mouse-event% event]) (if (not s-admin) @@ -315,7 +312,7 @@ (when rubberband? (set! rubberband? #f) - (rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) + (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y)) (add-selected start-x start-y (- last-x start-x) (- last-y start-y)) (update-all))) @@ -375,10 +372,12 @@ (when (send event dragging?) (cond [rubberband? + (begin-edit-sequence) ;; erase old - (rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) + (rubber-band-update start-x start-y (- last-x start-x) (- last-y start-y)) ;; draw new: - (rubber-band start-x start-y (- x start-x) (- y start-y))] + (rubber-band-update start-x start-y (- x start-x) (- y start-y)) + (end-edit-sequence)] [resizing (do-event-resize x y)] [else @@ -914,6 +913,8 @@ (on-resize snip w h) (set! write-locked (sub1 write-locked)) + (update-location loc) + (let ([rv? (and (send snip resize w h) (begin @@ -933,6 +934,8 @@ (after-resize snip w h rv?) + (update-location loc) + (set! write-locked (add1 write-locked)) (end-edit-sequence) (set! write-locked (sub1 write-locked)) @@ -1273,6 +1276,17 @@ show-caret 'no-caret)) + (when rubberband? + (let ([a (send dc get-alpha)]) + (send dc set-alpha (* a 0.5)) + (send dc set-brush rb-brush) + (send dc set-pen invisi-pen) + (send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h) + (send dc set-pen rb-pen) + (send dc set-alpha a) + (send dc set-brush invisi-brush) + (send dc draw-rectangle (+ rb-x dx) (+ rb-y dy) rb-w rb-h))) + (set! flow-locked? #f) (set! write-locked (sub1 write-locked)))))) @@ -1338,18 +1352,25 @@ [bgmode (send dc get-text-mode)] [rgn (send dc get-clipping-region)]) + (send dc suspend-flush) + (send dc set-clipping-rect (- left x) (- top y) width height) - - (draw dc (- x) (- y) left top width height show-caret bg-color) - - (send dc set-clipping-region rgn) - - (send dc set-brush brush) - (send dc set-pen pen) - (send dc set-font font) - (send dc set-text-foreground fg) - (send dc set-text-background bg) - (send dc set-text-mode bgmode))))) + + (dynamic-wind + void + (lambda () + (draw dc (- x) (- y) left top width height show-caret bg-color)) + (lambda () + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode) + + (send dc resume-flush))))))) (end-sequence-lock)))])) ;; ---------------------------------------- @@ -1409,8 +1430,8 @@ delayedscroll-x delayedscroll-y delayedscroll-w delayedscroll-h #t delayedscrollbias))) - (let ([r (+ x w)] - [b (+ y h)]) + (let ([r (if (symbol? w) x (+ x w))] + [b (if (symbol? h) y (+ y h))]) (let ([x (max x 0.0)] [y (max y 0.0)] [r (max r 0.0)] @@ -1422,51 +1443,42 @@ (begin (set! update-top y) (set! update-left x) - (set! update-bottom (if (h . < . 0) h b)) - (set! update-right (if (w . < . 0) w r)) + (set! update-bottom b) + (set! update-bottom-end (and (symbol? h) h)) + (set! update-right r) + (set! update-right-end (and (symbol? w) w)) (set! update-nonempty? #t)) (begin (set! update-top (min y update-top)) (set! update-left (min x update-left)) - (let ([ub (if (and (h . < . 0) (update-bottom . > . 0)) - (- update-bottom) - update-bottom)]) - (set! update-bottom - (if (ub . < . 0) - (if (and (h . < . 0) (h . < . ub)) - h - (if (and (h . > . 0) - ((- b) . < . ub)) - (- b) - ub)) - (max b ub)))) - (let ([ur (if (and (w . < . 0) (update-right . > . 0)) - (- update-right) - update-right)]) - (set! update-right - (if (ur . < . 0) - (if (and (w . < . 0) (w . < . ur)) - w - (if (and (w . > . 0) - ((- r) . < . ur)) - (- r) - ur)) - (max r ur)))))) + (set! update-bottom (max b update-bottom)) + (when (symbol? h) + (if (eq? h 'display-end) + (set! update-bottom-end 'display-end) + (unless (eq? update-bottom-end 'display-end) + (set! update-bottom-end 'end)))) + (set! update-right (max r update-right)) + (when (symbol? w) + (if (eq? w 'display-end) + (set! update-right-end 'display-end) + (unless (eq? update-right-end 'display-end) + (set! update-right-end 'end)))))) (unless (or (positive? sequence) (not s-admin) flow-locked?) (check-recalc) - (when (update-bottom . < . 0) - (set! update-bottom (- update-bottom)) - (when (update-bottom . < . real-height) - (set! update-bottom real-height))) - - (when (update-right . < . 0) - (set! update-right (- update-right)) - (when (update-right . < . real-width) - (set! update-right real-width))) + (let-boxes ([vx 0.0] [vy 0.0] [vw 0.0] [vh 0.0]) + (when (or (eq? update-bottom-end 'display-end) + (eq? update-right-end 'display-end)) + (send s-admin get-max-view x y w h)) + (case update-bottom-end + [(end) (set! update-bottom (max update-bottom real-height))] + [(display-end) (set! update-bottom (max update-bottom vh))]) + (case update-right-end + [(end) (set! update-right (max update-right real-width))] + [(display-end) (set! update-right (max update-right vw))])) (set! update-nonempty? #f) @@ -1520,9 +1532,9 @@ (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] - [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] - [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) - (update x y (if (symbol? w) -1.0 w) (if (symbol? h) -1.0 h))) + [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) + (update x y w h)) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index f932224d..be32c886 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -47,14 +47,9 @@ (define caret-pen (send the-pen-list find-or-create-pen "BLACK" 1 'xor)) (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) -(define outline-inactive-pen (send the-pen-list find-or-create-pen "BLACK" 1 'hilite)) -(define outline-brush (send the-brush-list find-or-create-brush "BLACK" 'hilite)) -(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") -(define outline-nonowner-brush (let ([b (new brush%)]) - (send b set-color "BLACK") - (send b set-stipple (make-object bitmap% xpattern 16 16)) - (send b set-style 'xor) - b)) +(define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) +(define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) +(define outline-nonowner-brush outline-brush) (define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (showcaret>= a b) @@ -277,8 +272,8 @@ (define refresh-end 0) (define refresh-l 0.0) (define refresh-t 0.0) - (define refresh-r 0.0) - (define refresh-b 0.0) + (define refresh-r 0.0) ; can be 'display-end + (define refresh-b 0.0) ; can be 'display-end (define last-draw-l 0.0) (define last-draw-t 0.0) @@ -3908,8 +3903,8 @@ #t)))) (define/public (refresh-box L T w h) - (let ([B (+ T h)] - [R (+ L w)]) + (let ([B (if (eq? h 'display-end) h (+ T h))] + [R (if (eq? w 'display-end) w (+ L w))]) (if refresh-box-unset? (begin (set! refresh-l L) @@ -3920,13 +3915,17 @@ (begin (when (L . < . refresh-l) (set! refresh-l L)) - (when (R . > . refresh-r) - (set! refresh-r R)) + (unless (eq? refresh-r 'display-end) + (when (or (eq? R 'display-end) + (R . > . refresh-r)) + (set! refresh-r R))) (when (T . < . refresh-t) (set! refresh-t T)) - (when (B . > . refresh-b) - (set! refresh-b B)))) - + (unless (eq? refresh-b 'display-end) + (when (or (eq? B 'display-end) + (B . > . refresh-b)) + (set! refresh-b B))))) + (set! draw-cached-in-bitmap? #f))) (def/override (needs-update [snip% snip] @@ -3943,10 +3942,10 @@ (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] - [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] - [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) - (let ([w (if (symbol? w) (- total-width x) w)] - [h (if (symbol? h) (- total-height y) h)]) + [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) + (let ([w (if (eq? w 'end) (- total-width x) w)] + [h (if (eq? h 'end) (- total-height y) h)]) (refresh-box x y w h) (when (zero? delay-refresh) @@ -4755,7 +4754,7 @@ (when (and resized? s-admin) (send s-admin resized #f)) - + (on-reflow))))))))))) (def/public (on-reflow) (void)) @@ -4809,9 +4808,13 @@ (values left right top bottom) (values (max refresh-l left) - (min refresh-r right) + (if (eq? refresh-r 'display-end) + right + (min refresh-r right)) (max refresh-t top) - (min refresh-b bottom)))]) + (if (eq? refresh-b 'display-end) + bottom + (min refresh-b bottom))))]) (set! refresh-unset? #t) (set! refresh-box-unset? #t) (set! refresh-all? #f) @@ -4879,13 +4882,19 @@ (min refresh-t top) top) right (if (not refresh-box-unset?) - (max bottom refresh-b) + (if (eq? refresh-b 'display-end) + bottom + (max bottom refresh-b)) bottom) #t)) (values (max refresh-l left) (max top refresh-t) - (min right refresh-r) - (min bottom refresh-b) + (if (eq? refresh-r 'display-end) + right + (min right refresh-r)) + (if (eq? refresh-b 'display-end) + bottom + (min bottom refresh-b)) #t)) (values left top right bottom refresh-all?))]) @@ -4919,7 +4928,7 @@ ;; called by the administrator to trigger a redraw (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [caret-status? show-caret] [(make-or-false color%) bg-color]) (cond [(or (width . <= . 0) (height . <= . 0)) (void)] @@ -4941,6 +4950,7 @@ (let ([show-caret (if (and caret-blinked? + (not (pair? show-caret)) (not (eq? show-caret 'no-caret)) (not s-caret-snip)) ;; maintain caret-blinked invariant @@ -4965,7 +4975,9 @@ (dc . is-a? . printer-dc%))] [show-xsel? (and ALLOW-X-STYLE-SELECTION? - (or (not (eq? 'show-caret show-caret)) s-caret-snip) + (or (and (not (eq? 'show-caret show-caret)) + (not (pair? show-caret))) + s-caret-snip) (eq? this editor-x-selection-owner) (not flash?) (not (= endpos startpos)))]) @@ -5028,16 +5040,23 @@ (send dc set-clipping-rect (- left x) (- top y) width height) - (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color) + (send dc suspend-flush) - (send dc set-clipping-region rgn) + (dynamic-wind + void + (lambda () + (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color)) + (lambda () + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode) - (send dc set-brush brush) - (send dc set-pen pen) - (send dc set-font font) - (send dc set-text-foreground fg) - (send dc set-text-background bg) - (send dc set-text-mode bgmode)))))) + (send dc resume-flush)))))))) (end-sequence-lock)))])) @@ -5057,7 +5076,8 @@ (let ([line (mline-find-location (unbox line-root-box) starty)]) - (when bg-color + (when (and bg-color + (not (pair? show-caret))) (let ([lsave-pen (send dc get-pen)] [lsave-brush (send dc get-brush)]) (let ([wb (if (and (= 255 (send bg-color red)) @@ -5078,7 +5098,8 @@ (let* ([call-on-paint (lambda (pre?) (on-paint pre? dc leftx starty rightx endy dx dy - (if (not s-caret-snip) + (if (or (pair? show-caret) + (not s-caret-snip)) show-caret 'no-caret)))] [paint-done @@ -5102,7 +5123,8 @@ (cond [(not line) (send (send s-style-list basic-style) switch-to dc old-style) - (when (and (eq? 'show-caret show-caret) (not s-caret-snip) + (when (and (eq? 'show-caret show-caret) + (not s-caret-snip) extra-line? (not pos-at-eol?) (= len -startpos) @@ -5121,120 +5143,124 @@ [last (snip->next (mline-last-snip line))] [bottombase (+ ycounter (mline-bottombase line))] [topbase (+ ycounter (mline-topbase line))]) - (let-values ([(hilite-some? hsxs hsxe hsys hsye old-style) - (let sloop ([snip first] - [p pcounter] - [x (mline-get-left-location line max-width)] - [hilite-some? #f] - [hsxs 0.0] - [hsxe 0.0] - [hsys 0.0] - [hsye 0.0] - [old-style old-style]) - (if (eq? snip last) - (values hilite-some? hsxs hsxe hsys hsye old-style) - (begin - (send (snip->style snip) switch-to dc old-style) - (let ([old-style (snip->style snip)]) - (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) - (send snip get-extent dc x ycounter w h descent space #f #f) - (let* ([align (send (snip->style snip) get-alignment)] - [down - (cond - [(eq? 'bottom align) - (+ (- bottombase h) descent)] - [(eq? 'top align) - (- topbase space)] - [else - (- (/ (+ topbase bottombase) 2) - (/ (- h descent space) 2) - space)])]) + (define (process-snips draw? maybe-hilite? old-style) + (let sloop ([snip first] + [p pcounter] + [x (mline-get-left-location line max-width)] + [hilite-some? #f] + [hsxs 0.0] + [hsxe 0.0] + [hsys 0.0] + [hsye 0.0] + [old-style old-style]) + (if (eq? snip last) + (values hilite-some? hsxs hsxe hsys hsye old-style) + (begin + (send (snip->style snip) switch-to dc old-style) + (let ([old-style (snip->style snip)]) + (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) + (send snip get-extent dc x ycounter w h descent space #f #f) + (let* ([align (send (snip->style snip) get-alignment)] + [down + (cond + [(eq? 'bottom align) + (+ (- bottombase h) descent)] + [(eq? 'top align) + (- topbase space)] + [else + (- (/ (+ topbase bottombase) 2) + (/ (- h descent space) 2) + space)])]) - (when (and (x . <= . rightx) - ((+ x w) . >= . leftx)) - (send snip draw dc (+ x dx) (+ down dy) - tleftx tstarty trightx tendy - dx dy - (if (eq? snip s-caret-snip) - show-caret - 'no-caret))) - - ;; the rules for hiliting are surprisingly complicated: - (let ([hilite? - (and - hilite-on? - (or show-xsel? - (and (not s-caret-snip) - (or (eq? 'show-caret show-caret) - (and (show-caret . showcaret>= . s-inactive-caret-threshold) - (not (= -endpos -startpos)))))) - (if pos-at-eol? - (= -startpos (+ p (snip->count snip))) - (or (and (-startpos . < . (+ p (snip->count snip))) - (-endpos . >= . p) - (or (= -endpos -startpos) (-endpos . > . p))) - (and (= (+ p (snip->count snip)) len) - (= len -startpos)))) - (or (not (has-flag? (snip->flags snip) NEWLINE)) - ;; end of line: - (or (not (= -startpos (+ p (snip->count snip)))) - (and (= -endpos -startpos) pos-at-eol?) - (and (not (= -endpos -startpos)) - (-startpos . < . (+ p (snip->count snip)))))) - (or (not (eq? snip first)) - ;; beginning of line: - (or (not (= p -endpos)) - (and (= -endpos -startpos) (not pos-at-eol?)) - (and (not (= -endpos -startpos)) - (-endpos . > . p)))))]) - - (if hilite? - (let*-values ([(bottom) (+ down h)] - [(hxs) (if (-startpos . <= . p) - (if (-startpos . < . p) - 0 - x) - (+ x (send snip partial-offset dc x ycounter - (- -startpos p))))] - [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) - (if (has-flag? (snip->flags snip) NEWLINE) - (if (= -startpos -endpos) - (values hxs bottom) - (values rightx - (+ ycounter (mline-h line)))) - (values (+ x w) bottom)) - (values (+ x (send snip partial-offset dc x ycounter - (- -endpos p))) - bottom))]) - - (let-values ([(hsxs hsxe hsys hsye) - (if (not hilite-some?) - (values hxs hxe down bottom) - (values hsxs hxe (min down hsys) (max hsye bottom)))]) - (sloop (snip->next snip) - (+ p (snip->count snip)) - (+ x w) - #t hsxs hsxe hsys hsye - old-style))) - (sloop (snip->next snip) - (+ p (snip->count snip)) - (+ x w) - hilite-some? hsxs hsxe hsys hsye - old-style)))))))))]) - (when (and (positive? wrap-bitmap-width) - (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) - last - (rightx . >= . max-width) - (send auto-wrap-bitmap ok?)) - (let ([h (min (->long (send auto-wrap-bitmap get-height)) - (mline-bottombase line))] - [osfg (send old-style get-foreground)]) - (send dc draw-bitmap-section - auto-wrap-bitmap - (sub1 (+ max-width dx)) (+ (- bottombase h) dy) - 0 0 wrap-bitmap-width h - 'solid osfg))) + (when draw? + (when (and (x . <= . rightx) + ((+ x w) . >= . leftx)) + (send snip draw dc (+ x dx) (+ down dy) + tleftx tstarty trightx tendy + dx dy + (if (pair? show-caret) + (cons p (+ p (snip->count snip))) + (if (eq? snip s-caret-snip) + show-caret + (if (and maybe-hilite? + (-endpos . > . p) + (-startpos . < . (+ p (snip->count snip)))) + (cons (max 0 (- -startpos p)) + (min (snip->count snip) (- -endpos p))) + 'no-caret)))))) + ;; the rules for hiliting are surprisingly complicated: + (let ([hilite? + (and + hilite-on? + (or show-xsel? + (and (not s-caret-snip) + (or (eq? 'show-caret show-caret) + (and (show-caret . showcaret>= . s-inactive-caret-threshold) + (not (= -endpos -startpos)))))) + (if pos-at-eol? + (= -startpos (+ p (snip->count snip))) + (or (and (-startpos . < . (+ p (snip->count snip))) + (-endpos . >= . p) + (or (= -endpos -startpos) (-endpos . > . p))) + (and (= (+ p (snip->count snip)) len) + (= len -startpos)))) + (or (not (has-flag? (snip->flags snip) NEWLINE)) + ;; end of line: + (or (not (= -startpos (+ p (snip->count snip)))) + (and (= -endpos -startpos) pos-at-eol?) + (and (not (= -endpos -startpos)) + (-startpos . < . (+ p (snip->count snip)))))) + (or (not (eq? snip first)) + ;; beginning of line: + (or (not (= p -endpos)) + (and (= -endpos -startpos) (not pos-at-eol?)) + (and (not (= -endpos -startpos)) + (-endpos . > . p)))))]) + + (if hilite? + (let*-values ([(bottom) (+ down h)] + [(hxs) (if (-startpos . <= . p) + (if (-startpos . < . p) + 0 + x) + (+ x (send snip partial-offset dc x ycounter + (- -startpos p))))] + [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) + (if (has-flag? (snip->flags snip) NEWLINE) + (if (= -startpos -endpos) + (values hxs bottom) + (values rightx + (+ ycounter (mline-h line)))) + (values (+ x w) bottom)) + (values (+ x (send snip partial-offset dc x ycounter + (- -endpos p))) + bottom))]) + + (let-values ([(hsxs hsxe hsys hsye) + (if (not hilite-some?) + (values hxs hxe down bottom) + (values hsxs hxe (min down hsys) (max hsye bottom)))]) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + #t hsxs hsxe hsys hsye + old-style))) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + hilite-some? hsxs hsxe hsys hsye + old-style)))))))))) + (let*-values ([(draw-first?) + (or (and (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?)) + (not show-xsel?)) + (= -startpos -endpos) + (-endpos . < . pcounter) + (-startpos . > . (+ pcounter (mline-len line))))] + [(hilite-some? hsxs hsxe hsys hsye old-style) + (process-snips draw-first? #f old-style)]) (let ([prevwasfirst (if hilite-some? (if (not (= hsxs hsxe)) @@ -5293,11 +5319,32 @@ (send dc set-pen save-pen)))) prevwasfirst)) prevwasfirst)]) - (lloop (mline-next line) - old-style - (+ ycounter (mline-h line)) - (+ pcounter (mline-len line)) - prevwasfirst))))]))))))))) + + (when (and (positive? wrap-bitmap-width) + (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) + last + (rightx . >= . max-width) + (send auto-wrap-bitmap ok?)) + (let ([h (min (->long (send auto-wrap-bitmap get-height)) + (mline-bottombase line))] + [osfg (send old-style get-foreground)]) + (send dc draw-bitmap-section + auto-wrap-bitmap + (sub1 (+ max-width dx)) (+ (- bottombase h) dy) + 0 0 wrap-bitmap-width h + 'solid osfg))) + + (let ([old-style + (if draw-first? + old-style + (let-values ([(_hilite-some? _hsxs _hsxe _hsys _hsye old-style) + (process-snips #t #t old-style)]) + old-style))]) + (lloop (mline-next line) + old-style + (+ ycounter (mline-h line)) + (+ pcounter (mline-len line)) + prevwasfirst)))))]))))))))) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index a50d9a08..fd248acf 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -3,11 +3,6 @@ (define the-clipboard (get-the-clipboard)) (define the-x-selection-clipboard (get-the-x-selection)) -(define the-brush-list (get-the-brush-list)) -(define the-pen-list (get-the-pen-list)) -(define the-font-list (get-the-font-list)) -(define the-color-database (get-the-color-database)) -(define the-font-name-directory (get-the-font-name-directory)) (define (family-symbol? s) (memq s '(default decorative roman script @@ -47,8 +42,6 @@ the-clipboard the-x-selection-clipboard get-double-click-threshold - begin-refresh-sequence - end-refresh-sequence begin-busy-cursor end-busy-cursor hide-cursor @@ -57,7 +50,9 @@ family-symbol? style-symbol? weight-symbol? - smoothing-symbol?) + smoothing-symbol? + get-highlight-background-color + get-highlight-text-color) (define (get-double-click-threshold) (get-double-click-time)) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index bbdc91f3..99e2017e 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -1,8 +1,8 @@ -(module wxpanel mzscheme +(module wxpanel racket/base (require mzlib/class mzlib/class100 mzlib/list - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "const.ss" "helper.ss" @@ -12,16 +12,19 @@ "wxitem.ss" "wxcontainer.ss") - (provide (protect wx-panel% - wx-vertical-panel% - wx-horizontal-panel% - wx-pane% - wx-vertical-pane% - wx-horizontal-pane% - wx-grow-box-pane%)) + (provide (protect-out wx-panel% + wx-vertical-panel% + wx-vertical-tab-panel% + wx-vertical-group-panel% + wx-horizontal-panel% + wx-control-horizontal-panel% + wx-pane% + wx-vertical-pane% + wx-horizontal-pane% + wx-grow-box-pane%)) (define wx:windowless-panel% - (class100 object% (prnt x y w h style) + (class100 object% (prnt x y w h style label) (private-field [pos-x 0] [pos-y 0] [width 1] [height 1] [parent prnt]) @@ -59,8 +62,8 @@ 0 2)) - (define (wx-make-basic-panel% wx:panel% stretch?) - (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style) + (define (wx-make-basic-panel% wx:panel% stretch? [x-m 0] [y-m 0]) + (class100* (wx-make-container% (make-item% wx:panel% x-m y-m stretch? stretch?)) (wx-basic-panel<%>) (parent style label) (inherit get-x get-y get-width get-height min-width min-height set-min-width set-min-height x-margin y-margin @@ -417,14 +420,8 @@ (raise-mismatch-error 'container-redraw "result from place-children is not a list of 4-integer lists with the correct length: " l)) - (when hidden-child - ;; This goes with the hack for macos and macosx below - (send hidden-child set-phantom-size width height)) (panel-redraw children children-info (if hidden-child - (cons (list 0 0 width - (if (memq (system-type) '(macos macosx)) ;; Yucky hack - (child-info-y-min (car children-info)) - height)) + (cons (list 0 0 width height) (let ([dy (child-info-y-min (car children-info))]) (map (lambda (i) (list (+ (car i) tab-h-border) @@ -455,7 +452,7 @@ child-infos placements))]) (sequence - (super-init style parent -1 -1 0 0 (cons 'deleted style)) + (super-init style parent -1 -1 0 0 (cons 'deleted style) label) (unless (memq 'deleted style) (send (get-top-level) show-control this #t))))) @@ -480,8 +477,8 @@ (sequence (apply super-init args)))) - (define (wx-make-panel% wx:panel%) - (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args + (define (wx-make-panel% wx:panel% [x-m 0] [y-m 0]) + (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t x-m y-m))) args (rename [super-on-visible on-visible] [super-on-active on-active]) (inherit get-children) @@ -728,20 +725,29 @@ (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f)) (define wx-panel% (wx-make-panel% wx:panel%)) + (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin)) + (define wx-tab-panel% (wx-make-panel% wx:tab-panel%)) + (define wx-group-panel% (wx-make-panel% wx:group-panel%)) (define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) + (define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%)) + (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%)) + (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%)) (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) + (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%)) + (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%)) + (define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%)) (define wx-pane% (wx-make-pane% wx:windowless-panel% #t)) (define wx-grow-box-pane% - (class100 (wx-make-pane% wx:windowless-panel% #f) (mred proxy parent style) + (class100 (wx-make-pane% wx:windowless-panel% #f) (mred proxy parent style label) (override [init-min (lambda (x) (if (or (eq? (system-type) 'macos) (eq? (system-type) 'macosx)) 15 0))]) (sequence - (super-init mred proxy parent style)))) + (super-init mred proxy parent style label)))) (define wx-linear-pane% (wx-make-linear-panel% wx-pane%)) (define wx-horizontal-pane% (wx-make-horizontal-panel% wx-linear-pane%)) (define wx-vertical-pane% (wx-make-vertical-panel% wx-linear-pane%))) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index f17688bb..6f4c7f39 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -1,9 +1,10 @@ -(module wxtextfield mzscheme +(module wxtextfield racket/base (require mzlib/class mzlib/class100 - (prefix wx: "kernel.ss") - (prefix wx: "wxme/text.ss") - (prefix wx: "wxme/editor-canvas.ss") + (prefix-in wx: "kernel.ss") + (prefix-in wx: "wxme/text.ss") + (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: "wxme/editor-canvas.ss") "lock.ss" "const.ss" "check.ss" @@ -17,18 +18,68 @@ "editor.ss" "mrpopup.ss") - (provide (protect wx-text-field%)) + (provide (protect-out wx-text-field%)) + + (define no-pen (send wx:the-pen-list find-or-create-pen "white" 1 'transparent)) + (define black-brush (send wx:the-brush-list find-or-create-brush "black" 'solid)) + + (define password-string-snip% + (class wx:string-snip% + (inherit get-count + get-style + get-text) + (super-new) + + (define delta 2) + (define (get-size) + (max 4 (send (send (get-style) get-font) get-point-size))) + + (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) + (let ([s (get-size)]) + (when w (set-box! w (* s (get-count)))) + (when h (set-box! h (+ s 2.0))) + (when descent (set-box! descent 1.0)) + (when space (set-box! space 1.0)) + (when lspace (set-box! lspace 0.0)) + (when rspace (set-box! rspace 0.0)))) + (define/override (partial-offset dc x y pos) + (let ([s (get-size)]) + (* s pos))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let ([s (get-size)] + [b (send dc get-brush)] + [p (send dc get-pen)] + [m (send dc get-smoothing)]) + (send dc set-pen no-pen) + (send dc set-brush black-brush) + (send dc set-smoothing 'aligned) + (for/fold ([x x]) ([i (in-range (get-count))]) + (send dc draw-ellipse (+ x delta) (+ y delta 1) (- s delta delta) (- s delta delta)) + (+ x s)) + (send dc set-pen p) + (send dc set-brush b) + (send dc set-smoothing m))) + (define/override (split pos first second) + (let ([a (new password-string-snip%)] + [b (new password-string-snip%)] + [c (get-count)]) + (send a insert (get-text 0 pos) pos) + (send b insert (get-text pos c) (- c pos)) + (set-box! first a) + (set-box! second b))))) (define text-field-text% - (class100 text% (cb ret-cb control set-cb-mgrs!) + (class100 text% (cb ret-cb control set-cb-mgrs! record-text pw?) (rename [super-on-char on-char]) - (inherit get-text last-position set-max-undo-history) + (inherit get-text last-position set-max-undo-history get-flattened-text) (private-field - [return-cb ret-cb]) + [return-cb ret-cb] + [password? pw?]) (private-field [block-callback 1] [callback (lambda (type) + (as-exit (lambda () (record-text (get-flattened-text)))) (when (zero? block-callback) (let ([e (make-object wx:control-event% type)]) (as-exit (lambda () @@ -41,7 +92,12 @@ (unless (and (or (eq? c #\return) (eq? c #\newline)) return-cb (return-cb (lambda () (callback 'text-field-enter) #t))) - (as-exit (lambda () (super-on-char e)))))))]) + (as-exit (lambda () (super-on-char e)))))))] + [on-new-string-snip + (lambda () + (if password? + (new password-string-snip%) + (super on-new-string-snip)))]) (augment [after-insert (lambda args @@ -88,7 +144,10 @@ this (lambda (wc cr) (set! without-callback wc) - (set! callback-ready cr)))]) + (set! callback-ready cr)) + (lambda (t) + (send c set-combo-text t)) + (memq 'password style))]) (sequence (as-exit (lambda () @@ -113,7 +172,12 @@ [get-canvas-width (lambda () (let ([tw (box 0)]) (send c get-size tw (box 0)) - (unbox tw)))]) + (unbox tw)))] + + [set-field-background (lambda (col) + (send c set-canvas-background col))] + [get-field-background (lambda () + (send c get-canvas-background))]) (override ;; These might be called before we are fully initialized @@ -131,7 +195,7 @@ (cdr r)) r))))]) (sequence - (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null)) + (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f) (unless (memq 'deleted style) (send (area-parent) add-child this))) (private-field @@ -143,7 +207,7 @@ [dy 0] [p (if horiz? this - (let ([p (make-object wx-vertical-pane% #f proxy this null)]) + (let ([p (make-object wx-vertical-pane% #f proxy this null #f)]) (send p skip-subwindow-events? #t) (send (send p area-parent) add-child p) p))]) @@ -152,12 +216,18 @@ (unless horiz? (send p alignment 'left 'top)) (unless multi? (stretchable-in-y #f)) ;; For Windows: - (wx:set-combo-box-font font) + ; (wx:set-combo-box-font font) (spacing 3)) (private-field [l (and label (make-object wx-message% #f proxy p label -1 -1 null font))] - [c (make-object wx-text-editor-canvas% #f proxy this p + [c (make-object (class wx-text-editor-canvas% + (define/override (on-combo-select i) + (let ([len (length callbacks)]) + (when (< -1 i len) + ((list-ref callbacks (- len i 1)))))) + (super-new)) + #f proxy this p (append '(control-border) (if (memq 'combo style) @@ -167,7 +237,15 @@ (if (memq 'hscroll style) null '(hide-hscroll)) - '(hide-vscroll hide-hscroll))))]) + '(hide-vscroll hide-hscroll))))] + [callbacks null]) + (public + [set-on-popup (lambda (proc) (send c set-on-popup proc))] + [clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))] + [append-combo-item (lambda (s cb) + (and (send c append-combo-item s) + (set! callbacks (cons cb callbacks)) + #t))]) (sequence (send c skip-subwindow-events? #t) (when l @@ -180,14 +258,7 @@ (send e auto-wrap (and multi? (not (memq 'hscroll style)))) (let ([f font] [s (send (send e get-style-list) find-named-style "Standard")]) - (send s set-delta (let ([d (font->delta f)]) - (if (memq 'password style) - (begin - (send d set-face #f) - (send d set-family 'modern) - (send d set-delta-foreground "darkgray") - (send d set-delta-background "darkgray")) - d)))) + (send s set-delta (font->delta f))) (send c set-editor e) (send c set-line-count (if multi? 3 1)) (unless multi? (send c set-single-line)) @@ -215,7 +286,7 @@ (set! dy (- dy (unbox ybox)))) ;; Subtract ascent of label - (send l get-text-extent "hi" wbox hbox ybox abox) + (send l get-text-extent "hi" wbox hbox ybox abox font) (set! dy (- dy (- (unbox hbox) (unbox ybox)))) ;; Subtract space above label @@ -223,7 +294,7 @@ ;; Exact (set! dy (inexact->exact dy)))) - + (when value (set-value value) (unless (string=? value "") diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index da720d36..c1fd3e71 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -35,7 +35,7 @@ (opt-lambda ([full-screen? #f]) (let ([xb (box 0)] [yb (box 0)]) - (wx:display-size xb yb (if full-screen? 1 0)) + (wx:display-size xb yb full-screen?) (values (unbox xb) (unbox yb))))) (define get-display-left-top-inset @@ -69,7 +69,8 @@ (define (make-top-container% base% dlg?) (class100 (wx-make-container% (wx-make-window% base% #t)) (parent . args) (inherit get-x get-y get-width get-height set-size - get-client-size is-shown? on-close enforce-size) + get-client-size is-shown? on-close enforce-size + get-eventspace) (private-field ;; have we had any redraw requests while the window has been ;; hidden? @@ -89,7 +90,7 @@ [panel #f] [use-default-position? (and (= -11111 (list-ref args 2)) - (= -11111 (list-ref args (if dlg? 3 1))))] + (= -11111 (list-ref args (if dlg? 3 1))))] [enabled? #t] [focus #f] @@ -107,13 +108,8 @@ (lambda (b) (set! enabled? (and b #t)) (super enable b))]) - (private-field - [eventspace (if parent - (send parent get-eventspace) - (wx:current-eventspace))]) (public - [get-eventspace (lambda () eventspace)] [is-enabled? (lambda () enabled?)] @@ -349,7 +345,7 @@ (set! last-height correct-h) (set! already-trying? #t) (enforce-size -1 -1 -1 -1 1 1) - (set-size -1 -1 correct-w correct-h) + (set-size -11111 -11111 correct-w correct-h) (enforce-size min-w min-h (if sx? -1 min-w) (if sy? -1 min-h) 1 1) @@ -400,7 +396,7 @@ [on-size (lambda (bad-width bad-height) (unless (and already-trying? (not (eq? 'unix (system-type)))) - (parameterize ([wx:current-eventspace eventspace]) + (parameterize ([wx:current-eventspace (get-eventspace)]) (wx:queue-callback (lambda () (resized)) #t))))]) (public @@ -494,7 +490,7 @@ #f)] [candidates (map object->position (container->children panel o #t))] - [dests (filter-overlapping candidates)] + [dests (filter-overlapping candidates)] [pos (if o (object->position o) (list 'x 0 0 1 1))] [o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4) (case code @@ -684,17 +680,11 @@ (when mb (set! menu-bar mb)) (super set-menu-bar mb))] [on-menu-command - (entry-point - (lambda (id) - (let ([wx (wx:id-to-menu-item id)]) - (let ([go (lambda () - (do-command (wx->mred wx) (make-object wx:control-event% 'menu)))]) - (if (eq? 'windows (system-type)) - ;; Windows: need trampoline - (wx:queue-callback - (entry-point (lambda () (go))) - wx:middle-queue-key) - (go))))))] + (entry-point + (lambda (id) + (let ([wx (wx:id-to-menu-item id)]) + (when wx + (do-command (wx->mred wx) (make-object wx:control-event% 'menu))))))] [on-menu-click (entry-point (lambda () @@ -730,7 +720,7 @@ (define wx-dialog% (make-top-level-window-glue% - 7 + 6 (class100 (make-top-container% wx:dialog% #t) args (sequence (apply super-init args)))))) diff --git a/collects/mred/private/wxwindow.rkt b/collects/mred/private/wxwindow.rkt index 8e708a78..be3d4766 100644 --- a/collects/mred/private/wxwindow.rkt +++ b/collects/mred/private/wxwindow.rkt @@ -2,6 +2,7 @@ (require mzlib/class mzlib/class100 (prefix wx: "kernel.ss") + "te.rkt" "lock.ss" "helper.ss" "wx.ss") @@ -39,6 +40,14 @@ [() skip-sub-events?] [(skip?) (set! skip-sub-events? skip?)])]) (public + [get-text-extent (lambda (s wb hb db ab font) + (let-values ([(w h d a) (get-window-text-extent* s font #t)]) + (let ([set (lambda (b v) + (when b (set-box! b (inexact->exact (ceiling v)))))]) + (set wb w) + (set hb h) + (set db d) + (set ab a))))] [on-active (lambda () (let ([act? (is-enabled-to-root?)]) @@ -171,7 +180,10 @@ [old-w -1] [old-h -1] [old-x -1] - [old-y -1]) + [old-y -1] + [expose-focus? #t]) + (public + [set-no-expose-focus (lambda () (set! expose-focus? #f))]) (override [on-drop-file (entry-point (lambda (f) @@ -201,21 +213,12 @@ (set! old-x x) (set! old-y y) (as-exit (lambda () (send mred on-move x y)))))))))))] - [on-set-focus (entry-point - (lambda () - ; Windows circumvents the event queue to call on-focus - ; when you click on the window's icon in the task bar. - (queue-window-callback - this - (lambda () (send (get-proxy) on-focus #t))) - (as-exit (lambda () (super on-set-focus)))))] - [on-kill-focus (entry-point - (lambda () - ; see on-set-focus: - (queue-window-callback - this - (lambda () (send (get-proxy) on-focus #f))) - (as-exit (lambda () (super on-kill-focus)))))] + [on-set-focus (lambda () + (super on-set-focus) + (when expose-focus? (send (get-proxy) on-focus #t)))] + [on-kill-focus (lambda () + (super on-kill-focus) + (when expose-focus? (send (get-proxy) on-focus #f)))] [pre-on-char (lambda (w e) (or (super pre-on-char w e) (if (skip-subwindow-events?) diff --git a/collects/mrlib/bitmap-label.rkt b/collects/mrlib/bitmap-label.rkt index 1d6a988d..08495da0 100644 --- a/collects/mrlib/bitmap-label.rkt +++ b/collects/mrlib/bitmap-label.rkt @@ -96,6 +96,7 @@ outside-margin (- (/ new-height 2) (/ img-height 2))) (send bitmap-dc set-bitmap #f) + new-bitmap))) (define (bitmap-label-maker text filename-or-bitmap) diff --git a/collects/mrlib/gif.rkt b/collects/mrlib/gif.rkt index 7c6f323e..17448855 100644 --- a/collects/mrlib/gif.rkt +++ b/collects/mrlib/gif.rkt @@ -4,10 +4,9 @@ scheme/class scheme/list net/gifwrite - scheme/contract) + racket/contract) - (provide write-gif - write-animated-gif) + (provide write-gif) (define (force-bm bm) (if (procedure? bm) (bm) bm)) @@ -76,6 +75,16 @@ (define (write-gif bm filename) (write-gifs (list bm) #f filename #f #f #f)) + (provide/contract + [write-animated-gif + (->i ((bms (and/c (listof (or/c (is-a?/c bitmap%) (-> (is-a?/c bitmap%)))) pair?)) + (delay (integer-in 0 4294967295)) + (filename (or/c path? string?))) + (#:one-at-a-time? (one-at-a-time? any/c) + #:last-frame-delay (last-frame-delay (or/c (integer-in 0 4294967295) false/c)) + #:loop? (Loop? (delay) (lambda (x) (and delay #t)))) + any)]) + (define (write-animated-gif bms delay filename #:one-at-a-time? [one-at-a-time? #f] #:last-frame-delay [last-frame-delay #f] diff --git a/collects/mrlib/hierlist.rkt b/collects/mrlib/hierlist.rkt index d42fdcde..c02b527d 100644 --- a/collects/mrlib/hierlist.rkt +++ b/collects/mrlib/hierlist.rkt @@ -22,13 +22,13 @@ (when f (f i))))] [on-select (lambda (i) - (printf "Selected: ~a~n" + (printf "Selected: ~a\n" (if i (send (send i get-editor) get-flattened-text) i)))] [on-double-select (lambda (s) - (printf "Double-click: ~a~n" + (printf "Double-click: ~a\n" (send (send s get-editor) get-flattened-text)))]) (sequence (apply super-init args))) p)) diff --git a/collects/mrlib/hierlist/hierlist-unit.rkt b/collects/mrlib/hierlist/hierlist-unit.rkt index 266efa79..5f946b68 100644 --- a/collects/mrlib/hierlist/hierlist-unit.rkt +++ b/collects/mrlib/hierlist/hierlist-unit.rkt @@ -27,10 +27,10 @@ (define transparent (make-object brush% "WHITE" 'transparent)) (define transparent-pen (make-object pen% "WHITE" 1 'transparent)) - (define black-xor-pen (make-object pen% "BLACK" 1 'hilite)) + (define black-xor-pen (make-object pen% (get-highlight-background-color) 1 'solid)) (define red (make-object brush% "RED" 'solid)) (define blue (make-object brush% "BLUE" 'solid)) - (define black-xor (make-object brush% "BLACK" 'hilite)) + (define black-xor (make-object brush% (get-highlight-background-color) 'solid)) (define arrow-cursor (make-object cursor% 'arrow)) (define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap) @@ -285,9 +285,17 @@ (set-max-width (if (positive? w) w 'none)))))])] + [refresh (lambda (x y width height draw-caret background) + (super refresh x y width height + (if (and selected? + (or (not (send top show-focus)) + (send top has-focus?))) + (cons 0 1) + draw-caret) + background))] [on-paint (lambda (pre? dc left top_ right bottom dx dy caret) - (when (and (not pre?) selected?) + (when (and pre? selected?) (let ([b (send dc get-brush)] [p (send dc get-pen)] [filled? (or (not (send top show-focus)) @@ -652,7 +660,7 @@ (define hierarchical-list% (class100 editor-canvas% (parent [style '(no-hscroll)]) - (inherit min-width min-height allow-tab-exit) + (inherit min-width min-height allow-tab-exit refresh) (rename [super-on-char on-char] [super-on-focus on-focus]) (public diff --git a/collects/mrlib/image-core-wxme.rkt b/collects/mrlib/image-core-wxme.rkt new file mode 100644 index 00000000..88906d33 --- /dev/null +++ b/collects/mrlib/image-core-wxme.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require racket/class + wxme + "private/image-core-snipclass.rkt" + "private/regmk.rkt") +(provide reader image<%>) + +(define guiless-image% + (class* object% (equal<%> image<%>) + (init-field pinhole bb) + (define/public (equal-to? that eq-recur) + (cond + [(eq? this that) #t] + [else (error 'image% "cannot do equality comparison without gui libraries")])) + (define/public (equal-hash-code-of y) 42) + (define/public (equal-secondary-hash-code-of y) 3) + + (define/public (get-shape) + (error 'image% "cannot get-shape without gui libraries")) + (define/public (set-shape s) + (error 'image% "cannot get-shape without gui libraries")) + (define/public (get-bb) bb) + (define/public (get-pinhole) pinhole) + (define/public (get-normalized?) #f) + (define/public (set-normalized? n?) (void)) + + (define/public (get-normalized-shape) + (error 'image% "cannot get-normalized-shape without gui libraries")) + + (super-new))) + +(define reader + (new + (class* object% (snip-reader<%>) + (define/public (read-header vers stream) + (void)) + (define/public (read-snip text? cvers stream) + (let* ([lst (fetch (send stream read-raw-bytes '2htdp/image))]) + (if text? + #"." + (let ([marshalled-img (list-ref lst 0)] + [marshalled-bb (list-ref lst 1)] + [marshalled-pinhole (list-ref lst 2)]) + (new guiless-image% + [bb (if (and (vector? marshalled-bb) + (= 4 (vector-length marshalled-bb)) + (eq? (vector-ref marshalled-bb 0) 'struct:bb) + (number? (vector-ref marshalled-bb 1)) + (number? (vector-ref marshalled-bb 2)) + (number? (vector-ref marshalled-bb 3))) + (apply make-bb (cdr (vector->list marshalled-bb))) + (make-bb 100 100 100))] + [pinhole + (if (and (vector? marshalled-pinhole) + (= 3 (vector-length marshalled-pinhole)) + (eq? (vector-ref marshalled-pinhole 0) 'struct:point) + (number? (vector-ref marshalled-pinhole 1)) + (number? (vector-ref marshalled-pinhole 2))) + (make-point (vector-ref marshalled-pinhole 1) + (vector-ref marshalled-pinhole 2)) + #f)]))))) + (super-new)))) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 9e474ebb..bab19783 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -1,10 +1,5 @@ #lang racket/base -;; changed: -;; - simple-shape -;; - np-atomic-shape -;; - atomic-shape - #| This library is the part of the 2htdp/image @@ -37,34 +32,13 @@ has been moved out). racket/math racket/contract "private/image-core-bitmap.ss" + "image-core-wxme.ss" + "private/image-core-snipclass.rkt" + "private/regmk.rkt" (prefix-in cis: "cache-image-snip.ss") (for-syntax racket/base)) -(define-for-syntax id-constructor-pairs '()) -(define-for-syntax (add-id-constructor-pair a b) - (set! id-constructor-pairs (cons (list a b) id-constructor-pairs))) -(define-syntax (define-struct/reg-mk stx) - (syntax-case stx () - [(_ id . rest) - (let ([build-name - (λ (fmt) - (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) - (add-id-constructor-pair (build-name "struct:~a") - (build-name "make-~a")) - #'(define-struct id . rest))])) - -(define-syntax (define-id->constructor stx) - (syntax-case stx () - [(_ fn) - #`(define (fn x) - (case x - #,@(map (λ (x) - (with-syntax ([(struct: maker) x]) - #`[(struct:) maker])) - id-constructor-pairs)))])) - -(define-struct/reg-mk point (x y) #:transparent) ; @@ -88,25 +62,21 @@ has been moved out). ;; a image is -;; (make-image shape bb boolean) +;; (make-image shape bb boolean (or/c point #f)) ;; NOTE: the shape field is mutated when normalized, as ;; is the normalized? field. -(define (make-image shape bb normalized?) (new image% [shape shape] [bb bb] [normalized? normalized?])) +(define (make-image shape bb normalized? [pinhole #f]) (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole])) (define (image-shape p) (send p get-shape)) (define (image-bb p) (send p get-bb)) (define (image-normalized? p) (send p get-normalized?)) (define (set-image-shape! p s) (send p set-shape s)) (define (set-image-normalized?! p n?) (send p set-normalized? n?)) (define (image? p) - (or (is-a? p image%) + (or (is-a? p image<%>) (is-a? p image-snip%) (is-a? p bitmap%))) -;; a bb is (bounding box) -;; (make-bb number number number) -(define-struct/reg-mk bb (right bottom baseline) #:transparent) - ;; a shape is either: ;; ;; - (make-overlay shape shape) @@ -147,9 +117,10 @@ has been moved out). ;; - flip ;; a bitmap is: -;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%))) +;; - (make-ibitmap (is-a?/c bitmap%) angle positive-real +;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods -(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable]) +(define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap raw-mask angle x-scale y-scale cache) #:omit-define-syntaxes #:transparent #:property prop:custom-write (λ (x y z) (bitmap-write x y z))) @@ -223,15 +194,12 @@ has been moved out). ; ;; ; ; ;;;; -(define-local-member-name - get-shape set-shape get-bb - get-normalized? set-normalized get-normalized-shape) - (define skip-image-equality-fast-path (make-parameter #f)) +(define render-normalized (make-parameter #f)) (define image% - (class* snip% (equal<%>) - (init-field shape bb normalized?) + (class* snip% (equal<%> image<%>) + (init-field shape bb normalized? pinhole) (define/public (equal-to? that eq-recur) (or (eq? this that) (let ([that @@ -241,30 +209,25 @@ has been moved out). [else that])]) (and (is-a? that image%) (same-bb? bb (send that get-bb)) + (equal? pinhole (send that get-pinhole)) (or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective (equal? (get-normalized-shape) (send that get-normalized-shape))) (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. - (or (zero? w) - (zero? h) - (let ([bm1 (make-object bitmap% w h)] - [bm2 (make-object bitmap% w h)] + (or ;(zero? w) + ;(zero? h) + (let ([bm1 (make-bitmap w h #t)] + [bm2 (make-bitmap w h #t)] [bytes1 (make-bytes (* w h 4) 0)] [bytes2 (make-bytes (* w h 4) 0)] [bdc (make-object bitmap-dc%)]) - (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that) - (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))) + (draw-into bm1 bdc bytes1 this) + (draw-into bm2 bdc bytes2 that) + (equal? bytes1 bytes2))))))))) - (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that) - (clear-bitmap/draw/bytes bm1 bdc bytes1 this color) - (clear-bitmap/draw/bytes bm2 bdc bytes2 that color) - (equal? bytes1 bytes2)) - - (define/private (clear-bitmap/draw/bytes bm bdc bytes obj color) + (define/private (draw-into bm bdc bytes obj) (send bdc set-bitmap bm) - (send bdc set-pen "black" 1 'transparent) - (send bdc set-brush color 'solid) - (send bdc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send bdc clear) (render-image obj bdc 0 0) (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes)) @@ -274,6 +237,7 @@ has been moved out). (define/public (get-shape) shape) (define/public (set-shape s) (set! shape s)) (define/public (get-bb) bb) + (define/public (get-pinhole) pinhole) (define/public (get-normalized?) normalized?) (define/public (set-normalized? n?) (set! normalized? n?)) @@ -314,7 +278,7 @@ has been moved out). (calc-scroll-step) (inexact->exact (ceiling (/ y scroll-step)))) - (define/override (copy) (make-image shape bb normalized?)) + (define/override (copy) (make-image shape bb normalized? pinhole)) (define/override (draw dc x y left top right bottom dx dy draw-caret?) (let ([smoothing (send dc get-smoothing)]) (render-image this dc x y))) @@ -331,7 +295,7 @@ has been moved out). (set-box/f! rspace 0))) (define/override (write f) - (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb)))]) + (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))]) (send f put (bytes-length bytes) bytes))) (super-new) @@ -348,30 +312,24 @@ has been moved out). (define image-snipclass% (class snip-class% (define/override (read f) - (let* ([bytes (send f get-unterminated-bytes)] - [str - (and bytes - (with-handlers ((exn:fail? (λ (x) #f))) - (bytes->string/utf-8 bytes)))] - [lst - (and str - (with-handlers ((exn:fail:read? (λ (x) #f))) - (parse - (racket/base:read - (open-input-string - str)))))]) - (if lst - (make-image (list-ref lst 0) - (list-ref lst 1) - #f) - (make-image (make-ellipse 100 100 0 'solid "black") - (make-bb 100 100 100) - #f)))) + (let ([lst (parse (fetch (send f get-unterminated-bytes)))]) + (cond + [(not lst) + (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black")) + (make-bb 100 100 100) + #f + #f)] + [else + (make-image (list-ref lst 0) + (list-ref lst 1) + #f + (list-ref lst 2))]))) (super-new))) (provide snip-class) (define snip-class (new image-snipclass%)) -(send snip-class set-classname (format "~s" '(lib "image-core.ss" "mrlib"))) +(send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib") + '(lib "image-core-wxme.rkt" "mrlib")))) (send snip-class set-version 1) (send (get-the-snip-class-list) add snip-class) @@ -382,6 +340,8 @@ has been moved out). (let loop ([sexp sexp]) (cond [(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))] + [(and (immutable? sexp) (hash? sexp)) + (hash-copy sexp)] [(vector? sexp) (if (= (vector-length sexp) 0) (k #f) @@ -390,17 +350,28 @@ has been moved out). ;; bitmaps are vectors with a bytes in the first field (apply bytes->bitmap (vector->list sexp))] [else - (let ([constructor (id->constructor (vector-ref sexp 0))] - [args (cdr (vector->list sexp))]) - (if (and constructor - (procedure-arity-includes? constructor (length args))) - (apply constructor (map loop args)) - (k #f)))]))] + (let* ([tag (vector-ref sexp 0)] + [args (cdr (vector->list sexp))] + [constructor (id->constructor tag)] + [arg-count (length args)] + [parsed-args (map loop args)]) + (cond + [(and constructor (procedure-arity-includes? constructor arg-count)) + (apply constructor parsed-args)] + [(and (eq? tag 'struct:bitmap) + (= arg-count 7)) + ;; we changed the arity of the bitmap constructor from old versions, + ;; so fix it up here. + (make-bitmap (list-ref parsed-args 0) + (list-ref parsed-args 1) + (list-ref parsed-args 2) + (list-ref parsed-args 3) + (list-ref parsed-args 4) + (make-hash))] + [else + (k #f)]))]))] [else sexp])))) -(define-id->constructor id->constructor) - - (define (normalized-shape? s) (cond [(overlay? s) @@ -427,7 +398,7 @@ has been moved out). (or (polygon? shape) (line-segment? shape) (curve-segment? shape) - (bitmap? shape) + (ibitmap? shape) (np-atomic-shape? shape))) (define (np-atomic-shape? shape) @@ -435,14 +406,13 @@ has been moved out). (text? shape) (and (flip? shape) (boolean? (flip-flipped? shape)) - (bitmap? (flip-shape shape))))) + (ibitmap? (flip-shape shape))))) -;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape +;; normalize-shape : shape -> normalized-shape ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. -(define/contract (normalize-shape shape [f values]) - (->* (any/c) ;; should be shape? - ((-> any/c any/c)) - normalized-shape?) +(define/contract (normalize-shape shape) + (-> any/c ;; should be shape? + normalized-shape?) (let loop ([shape shape] [dx 0] [dy 0] @@ -489,16 +459,16 @@ has been moved out). (polygon-mode shape) (scale-color (polygon-color shape) x-scale y-scale))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] + (make-overlay bottom this-one) + this-one))] [(line-segment? shape) (let ([this-one (make-line-segment (scale-point (line-segment-start shape)) (scale-point (line-segment-end shape)) (scale-color (line-segment-color shape) x-scale y-scale))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] + (make-overlay bottom this-one) + this-one))] [(curve-segment? shape) ;; the pull is multiplied by the distance ;; between the two points when it is drawn, @@ -512,17 +482,17 @@ has been moved out). (curve-segment-e-pull shape) (scale-color (curve-segment-color shape) x-scale y-scale))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] - [(or (bitmap? shape) (np-atomic-shape? shape)) - (let ([shape (if (bitmap? shape) + (make-overlay bottom this-one) + this-one))] + [(or (ibitmap? shape) (np-atomic-shape? shape)) + (let ([shape (if (ibitmap? shape) (make-flip #f shape) shape)]) (let ([this-one (make-translate dx dy (scale-np-atomic x-scale y-scale shape))]) (if bottom - (make-overlay bottom (f this-one)) - (f this-one))))] + (make-overlay bottom this-one) + this-one)))] [else (error 'normalize-shape "unknown shape ~s\n" shape)]))) @@ -550,14 +520,18 @@ has been moved out). (text-weight shape) (text-underline shape))] [(flip? shape) - (let ([bitmap (flip-shape shape)]) - (make-flip (flip-flipped? shape) - (make-bitmap (bitmap-raw-bitmap bitmap) - (bitmap-raw-mask bitmap) - (bitmap-angle bitmap) - (* x-scale (bitmap-x-scale bitmap)) - (* y-scale (bitmap-y-scale bitmap)) - #f #f)))])) + (cond + [(and (= 1 x-scale) (= 1 y-scale)) + shape] + [else + (let ([bitmap (flip-shape shape)]) + (make-flip (flip-flipped? shape) + (make-ibitmap (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap) + (ibitmap-angle bitmap) + (* x-scale (ibitmap-x-scale bitmap)) + (* y-scale (ibitmap-y-scale bitmap)) + (ibitmap-cache bitmap))))])])) (define (scale-color color x-scale y-scale) (cond @@ -594,19 +568,40 @@ has been moved out). [brush (send dc get-brush)] [font (send dc get-font)] [fg (send dc get-text-foreground)] - [smoothing (send dc get-smoothing)]) + [smoothing (send dc get-smoothing)] + [alpha (send dc get-alpha)]) (cond [(is-a? image bitmap%) (send dc draw-bitmap image dx dy)] [(is-a? image image-snip%) (send dc draw-bitmap (send image get-bitmap) dx dy)] [else - (render-normalized-shape (send image get-normalized-shape) dc dx dy)]) + (if (render-normalized) + (render-normalized-shape (send image get-normalized-shape) dc dx dy) + (render-arbitrary-shape (send image get-shape) dc dx dy)) + (let ([ph (send image get-pinhole)]) + (when ph + (let* ([px (point-x ph)] + [py (point-y ph)] + [bb (image-bb image)] + [w (bb-right bb)] + [h (bb-bottom bb)]) + (send dc set-alpha (* alpha .5)) + (send dc set-smoothing 'smoothed) + + (send dc set-pen "white" 1 'solid) + (send dc draw-line (+ dx px .5) (+ dy .5) (+ dx px .5) (+ dy h -.5)) + (send dc draw-line (+ dx .5) (+ dy py .5) (+ dx w -.5) (+ dy py .5)) + + (send dc set-pen "black" 1 'solid) + (send dc draw-line (+ dx px -.5) (+ dy .5) (+ dx px -.5) (+ dy h -.5)) + (send dc draw-line (+ dx .5) (+ dy py -.5) (+ dx w -.5) (+ dy py -.5)))))]) (send dc set-pen pen) (send dc set-brush brush) (send dc set-font font) (send dc set-text-foreground fg) - (send dc set-smoothing smoothing))) + (send dc set-smoothing smoothing) + (send dc set-alpha alpha))) (define (save-image-as-bitmap image filename kind) (let* ([bb (send image get-bb)] @@ -632,24 +627,103 @@ has been moved out). (define (render-cn-or-simple-shape shape dc dx dy) (cond [(crop? shape) - (let ([points (crop-points shape)]) - (cond - [(equal? points (last-cropped-points)) - (render-normalized-shape (crop-shape shape) dc dx dy)] - [else - (let ([old-region (send dc get-clipping-region)] - [new-region (new region% [dc dc])] - [path (polygon-points->path points)]) - (send new-region set-path path dx dy) - (when old-region (send new-region intersect old-region)) - (send dc set-clipping-region new-region) - (parameterize ([last-cropped-points points]) - (render-normalized-shape (crop-shape shape) dc dx dy)) - (send dc set-clipping-region old-region))]))] + (render-cropped-shape (crop-points shape) (crop-shape shape) (λ (s) (render-normalized-shape s dc dx dy)) dc dx dy)] [else (render-simple-shape shape dc dx dy)])) +(define (render-cropped-shape points inner-shape continue dc dx dy) + (cond + [(equal? points (last-cropped-points)) + (continue inner-shape)] + [else + (let ([old-region (send dc get-clipping-region)] + [new-region (new region% [dc dc])] + [path (polygon-points->path points)]) + (send new-region set-path path dx dy) + (when old-region (send new-region intersect old-region)) + (send dc set-clipping-region new-region) + (parameterize ([last-cropped-points points]) + (continue inner-shape)) + (send dc set-clipping-region old-region))])) + (define (render-simple-shape simple-shape dc dx dy) + (cond + [(translate? simple-shape) + (let ([dx (+ dx (translate-dx simple-shape))] + [dy (+ dy (translate-dy simple-shape))] + [np-atomic-shape (translate-shape simple-shape)]) + (render-np-atomic-shape np-atomic-shape + dc + dx dy))] + [else + (render-poly/line-segment/curve-segment simple-shape dc dx dy)])) + +(define (render-arbitrary-shape shape dc dx dy) + (let loop ([shape shape] + [dx dx] + [dy dy] + [x-scale 1] + [y-scale 1]) + (define (scale-point p) + (make-point (* x-scale (point-x p)) + (* y-scale (point-y p)))) + (cond + [(translate? shape) + (loop (translate-shape shape) + (+ dx (* x-scale (translate-dx shape))) + (+ dy (* y-scale (translate-dy shape))) + x-scale + y-scale)] + [(scale? shape) + (loop (scale-shape shape) + dx + dy + (* x-scale (scale-x shape)) + (* y-scale (scale-y shape)))] + [(overlay? shape) + (loop (overlay-bottom shape) dx dy x-scale y-scale) + (loop (overlay-top shape) dx dy x-scale y-scale)] + [(crop? shape) + (render-cropped-shape + (map scale-point (crop-points shape)) + (crop-shape shape) + (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] + [(polygon? shape) + (let* ([this-one + (make-polygon (map scale-point (polygon-points shape)) + (polygon-mode shape) + (scale-color (polygon-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(line-segment? shape) + (let ([this-one + (make-line-segment (scale-point (line-segment-start shape)) + (scale-point (line-segment-end shape)) + (scale-color (line-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(curve-segment? shape) + ;; the pull is multiplied by the distance + ;; between the two points when it is drawn, + ;; so we don't need to scale it here + (let ([this-one + (make-curve-segment (scale-point (curve-segment-start shape)) + (curve-segment-s-angle shape) + (curve-segment-s-pull shape) + (scale-point (curve-segment-end shape)) + (curve-segment-e-angle shape) + (curve-segment-e-pull shape) + (scale-color (curve-segment-color shape) x-scale y-scale))]) + (render-poly/line-segment/curve-segment this-one dc dx dy))] + [(or (ibitmap? shape) (np-atomic-shape? shape)) + (let* ([shape (if (ibitmap? shape) + (make-flip #f shape) + shape)] + [this-one (scale-np-atomic x-scale y-scale shape)]) + (render-np-atomic-shape this-one dc dx dy))] + [else + (error 'normalize-shape "unknown shape ~s\n" shape)]))) + +(define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy) + (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?) (cond [(polygon? simple-shape) (let ([mode (polygon-mode simple-shape)] @@ -697,63 +771,63 @@ has been moved out). (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape))) (send dc set-brush "black" 'transparent) (send dc set-smoothing 'smoothed) - (send dc draw-path path dx dy))] - [else - (let ([dx (+ dx (translate-dx simple-shape))] - [dy (+ dy (translate-dy simple-shape))] - [np-atomic-shape (translate-shape simple-shape)]) - (cond - [(ellipse? np-atomic-shape) - (let* ([path (new dc-path%)] - [ew (ellipse-width np-atomic-shape)] - [eh (ellipse-height np-atomic-shape)] - [θ (degrees->radians (ellipse-angle np-atomic-shape))] - [color (ellipse-color np-atomic-shape)] - [mode (ellipse-mode np-atomic-shape)]) - (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) - (send path ellipse 0 0 ew eh) - (send path translate (- (/ ew 2)) (- (/ eh 2))) - (send path rotate θ) - (send dc set-pen (mode-color->pen mode color)) - (send dc set-brush (mode-color->brush mode color)) - (send dc set-smoothing (mode-color->smoothing mode color)) - (send dc draw-path path dx dy)))] - [(flip? np-atomic-shape) - (let ([bm (get-rendered-bitmap np-atomic-shape)]) - (send dc draw-bitmap - bm - (- dx (/ (send bm get-width) 2)) - (- dy (/ (send bm get-height) 2)) - 'solid - (send the-color-database find-color "black") - (get-rendered-mask np-atomic-shape)))] - [(text? np-atomic-shape) - (let ([θ (degrees->radians (text-angle np-atomic-shape))] - [font (send dc get-font)]) - (send dc set-font (text->font np-atomic-shape)) - (let ([color (get-color-arg (text-color np-atomic-shape))]) - (send dc set-text-foreground - (cond - [(string? color) - (or (send the-color-database find-color color) - (send the-color-database find-color "black"))] - [else color]))) - (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))]) - (let ([p (- (make-rectangular dx dy) - (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) - (send dc draw-text (text-string np-atomic-shape) - (real-part p) - (imag-part p) - #f 0 θ))))]))])) + (send dc draw-path path dx dy))])) + +(define (render-np-atomic-shape np-atomic-shape dc dx dy) + (cond + [(ellipse? np-atomic-shape) + (let* ([path (new dc-path%)] + [ew (ellipse-width np-atomic-shape)] + [eh (ellipse-height np-atomic-shape)] + [θ (degrees->radians (ellipse-angle np-atomic-shape))] + [color (ellipse-color np-atomic-shape)] + [mode (ellipse-mode np-atomic-shape)]) + (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) + (send path ellipse 0 0 ew eh) + (send path translate (- (/ ew 2)) (- (/ eh 2))) + (send path rotate θ) + (send dc set-pen (mode-color->pen mode color)) + (send dc set-brush (mode-color->brush mode color)) + (send dc set-smoothing (mode-color->smoothing mode color)) + (send dc draw-path path dx dy)))] + [(flip? np-atomic-shape) + (let ([bm (get-rendered-bitmap np-atomic-shape)]) + (send dc set-smoothing 'smoothed) + (send dc draw-bitmap + bm + (- dx (/ (send bm get-width) 2)) + (- dy (/ (send bm get-height) 2)) + 'solid + (send the-color-database find-color "black") + (get-rendered-mask np-atomic-shape)))] + [(text? np-atomic-shape) + (let ([θ (degrees->radians (text-angle np-atomic-shape))] + [font (send dc get-font)]) + (send dc set-font (text->font np-atomic-shape)) + (send dc set-smoothing 'aligned) ;; should this be smoothed? + (let ([color (get-color-arg (text-color np-atomic-shape))]) + (send dc set-text-foreground + (cond + [(string? color) + (or (send the-color-database find-color color) + (send the-color-database find-color "black"))] + [else color]))) + (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))]) + (let ([p (- (make-rectangular dx dy) + (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) + (send dc draw-text (text-string np-atomic-shape) + (real-part p) + (imag-part p) + #f 0 θ))))])) (define (polygon-points->path points) (let ([path (new dc-path%)]) - (send path move-to (round (point-x (car points))) (round (point-y (car points)))) + (send path move-to (point-x (car points)) (point-y (car points))) (let loop ([points (cdr points)]) (unless (null? points) (send path line-to - (round (point-x (car points))) - (round (point-y (car points)))) + (point-x (car points)) + (point-y (car points))) (loop (cdr points)))) (send path close) ;(send path line-to (round (point-x (car points))) (round (point-y (car points)))) @@ -795,89 +869,104 @@ the mask bitmap and the original bitmap are all together in a single bytes! (define (get-rendered-bitmap flip-bitmap) - (calc-rendered-bitmap flip-bitmap) - (bitmap-rendered-bitmap (flip-shape flip-bitmap))) + (let ([key (get-bitmap-cache-key flip-bitmap)]) + (calc-rendered-bitmap flip-bitmap key) + (car (hash-ref (ibitmap-cache (flip-shape flip-bitmap)) + key)))) (define (get-rendered-mask flip-bitmap) - (calc-rendered-bitmap flip-bitmap) - (bitmap-rendered-mask (flip-shape flip-bitmap))) + (let ([key (get-bitmap-cache-key flip-bitmap)]) + (calc-rendered-bitmap flip-bitmap key) + (cdr (hash-ref (ibitmap-cache (flip-shape flip-bitmap)) + key)))) -(define (calc-rendered-bitmap flip-bitmap) +(define (get-bitmap-cache-key flip-bitmap) + (let ([bm (flip-shape flip-bitmap)]) + (list (flip-flipped? flip-bitmap) + (ibitmap-x-scale bm) + (ibitmap-y-scale bm) + (ibitmap-angle bm)))) + +(define (calc-rendered-bitmap flip-bitmap key) (let ([bitmap (flip-shape flip-bitmap)]) - (unless (bitmap-rendered-bitmap bitmap) - (let ([flipped? (flip-flipped? flip-bitmap)]) - - ;; fill in the rendered bitmap with the raw bitmaps. - (set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap)) - (set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap)) - (cond - [(and (= 1 (bitmap-x-scale bitmap)) - (= 1 (bitmap-y-scale bitmap)) - (= 0 (bitmap-angle bitmap)) - (not flipped?)) - ;; if there's no scaling, rotation or flipping, we can just keep that bitmap. - (void)] - [(<= (* (bitmap-x-scale bitmap) - (bitmap-y-scale bitmap)) - 1) - ;; since we prefer to rotate big things, we rotate first - (do-rotate bitmap flipped?) - (do-scale bitmap)] - [else - ;; since we prefer to rotate big things, we scale first - (do-scale bitmap) - (do-rotate bitmap flipped?)]))))) + (cond + [(hash-ref (ibitmap-cache bitmap) key #f) => (λ (x) x)] + [else + (let ([flipped? (flip-flipped? flip-bitmap)]) + (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap))) + (define-values (bitmap-obj mask-obj) + (cond + [(<= (* (ibitmap-x-scale bitmap) + (ibitmap-y-scale bitmap)) + 1) + ;; since we prefer to rotate big things, we rotate first + (let-values ([(bitmap-obj mask-obj) (do-rotate bitmap orig-bitmap-obj orig-mask-obj flipped?)]) + (do-scale bitmap bitmap-obj mask-obj))] + [else + ;; since we prefer to rotate big things, we scale first + (let-values ([(bitmap-obj mask-obj) (do-scale bitmap orig-bitmap-obj orig-mask-obj)]) + (do-rotate bitmap bitmap-obj mask-obj flipped?))])) + (define pair (cons bitmap-obj mask-obj)) + (hash-set! (ibitmap-cache bitmap) key pair) + pair)]))) -(define (do-rotate bitmap flip?) - (let ([θ (degrees->radians (bitmap-angle bitmap))]) - (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) - (bitmap-rendered-mask bitmap))]) - (let-values ([(rotated-bytes rotated-w rotated-h) - (rotate-bytes bytes w h θ)]) - (let* ([flipped-bytes (if flip? - (flip-bytes rotated-bytes rotated-w rotated-h) - rotated-bytes)] - [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] - [mask (send bm get-loaded-mask)]) - (set-bitmap-rendered-bitmap! bitmap bm) - (set-bitmap-rendered-mask! bitmap mask)))))) +(define (do-rotate bitmap bitmap-obj mask-obj flip?) + (cond + [(and (not flip?) (zero? (ibitmap-angle bitmap))) + ;; don't rotate anything in this case. + (values bitmap-obj mask-obj)] + [else + (let ([θ (degrees->radians (ibitmap-angle bitmap))]) + (let-values ([(bytes w h) (bitmap->bytes bitmap-obj mask-obj)]) + (let-values ([(rotated-bytes rotated-w rotated-h) + (rotate-bytes bytes w h θ)]) + (let* ([flipped-bytes (if flip? + (flip-bytes rotated-bytes rotated-w rotated-h) + rotated-bytes)] + [bm (bytes->bitmap flipped-bytes rotated-w rotated-h)] + [mask (send bm get-loaded-mask)]) + (values bm mask)))))])) -(define (do-scale bitmap) - (let* ([bdc (make-object bitmap-dc%)] - [orig-bm (bitmap-rendered-bitmap bitmap)] - [orig-mask (bitmap-rendered-mask bitmap)] - [orig-w (send orig-bm get-width)] - [orig-h (send orig-bm get-height)] - [x-scale (bitmap-x-scale bitmap)] - [y-scale (bitmap-y-scale bitmap)] - [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] - [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] - [new-bm (make-object bitmap% scale-w scale-h)] - [new-mask (and orig-mask (make-object bitmap% scale-w scale-h))]) - (when new-mask - (send new-bm set-loaded-mask new-mask)) - - (send bdc set-bitmap new-bm) - (send bdc set-scale x-scale y-scale) - (send bdc clear) - (send bdc draw-bitmap orig-bm 0 0) - - (when new-mask - (send bdc set-bitmap new-mask) - (send bdc set-scale x-scale y-scale) - (send bdc clear) - (send bdc draw-bitmap orig-mask 0 0)) - - (send bdc set-bitmap #f) - - (set-bitmap-rendered-bitmap! bitmap new-bm) - (set-bitmap-rendered-mask! bitmap new-mask))) +(define (do-scale bitmap orig-bm orig-mask) + (let ([x-scale (ibitmap-x-scale bitmap)] + [y-scale (ibitmap-y-scale bitmap)]) + (cond + [(and (= 1 x-scale) (= 1 y-scale)) + ;; no need to scale in this case + (values orig-bm orig-mask)] + [else + (let* ([bdc (make-object bitmap-dc%)] + [orig-w (send orig-bm get-width)] + [orig-h (send orig-bm get-height)] + [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] + [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] + [new-bm (make-object bitmap% scale-w scale-h)] + [new-mask (and orig-mask (make-object bitmap% scale-w scale-h))]) + (when new-mask + (send new-bm set-loaded-mask new-mask)) + + (send bdc set-bitmap new-bm) + (send bdc set-scale x-scale y-scale) + (send bdc clear) + (send bdc draw-bitmap orig-bm 0 0) + + (when new-mask + (send bdc set-bitmap new-mask) + (send bdc set-scale x-scale y-scale) + (send bdc clear) + (send bdc draw-bitmap orig-mask 0 0)) + + (send bdc set-bitmap #f) + + (values new-bm new-mask))]))) (define (text->font text) + (define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255)) (cond [(text-face text) (send the-font-list find-or-create-font - (text-size text) + adjusted-size (text-face text) (text-family text) (text-style text) @@ -885,7 +974,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (text-underline text))] [else (send the-font-list find-or-create-font - (text-size text) + adjusted-size (text-family text) (text-style text) (text-weight text) @@ -927,7 +1016,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [(pen? color) (pen->pen-obj/cache color)] [else - (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid)])] + (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])] [(solid) (send the-pen-list find-or-create-pen "black" 1 'transparent)])) @@ -947,32 +1036,13 @@ the mask bitmap and the original bitmap are all together in a single bytes! (color-blue color)))) -(define pen-ht (make-hash)) - (define (pen->pen-obj/cache pen) - (cond - [(and (equal? 'round (pen-join pen)) - (equal? 'round (pen-cap pen))) - (send the-pen-list find-or-create-pen - (pen-color pen) - (pen-width pen) - (pen-style pen))] - [else - (let* ([wb/f (hash-ref pen-ht pen #f)] - [pen-obj/f (and (weak-box? wb/f) (weak-box-value wb/f))]) - (or pen-obj/f - (let ([pen-obj (pen->pen-obj pen)]) - (hash-set! pen-ht pen (make-weak-box pen-obj)) - pen-obj)))])) - -(define (pen->pen-obj pen) - (let ([ans (make-object pen% - (pen-color pen) - (pen-width pen) - (pen-style pen))]) - (send ans set-cap (pen-cap pen)) - (send ans set-join (pen-join pen)) - ans)) + (send the-pen-list find-or-create-pen + (pen-color pen) + (pen-width pen) + (pen-style pen) + (pen-cap pen) + (pen-join pen))) (define (to-img arg) (cond @@ -1007,7 +1077,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [h (send bm get-height)]) (make-image (make-translate (/ w 2) (/ h 2) - (make-bitmap bm mask-bm 0 1 1 #f #f)) + (make-ibitmap bm mask-bm 0 1 1 (make-hash))) (make-bb w h h) #f))) @@ -1020,13 +1090,13 @@ the mask bitmap and the original bitmap are all together in a single bytes! [update (λ (i) (let ([o (vector-ref v i)]) - (let ([nv (call-with-values (λ () (bitmap->bytes o)) vector)]) + (let ([nv (and o + (call-with-values (λ () (bitmap->bytes o)) vector))]) (vector-set! v i nv))))]) (update 1) (update 2) - ;; don't save the rendered bitmap (if it is there) - (vector-set! v 6 #f) - (vector-set! v 7 #f) + ;; don't save the cache + (vector-set! v 6 (make-hash)) (recur v port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1051,8 +1121,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! curve-segment-color make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen - make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale - bitmap-rendered-bitmap bitmap-rendered-mask + make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-raw-mask ibitmap-angle ibitmap-x-scale ibitmap-y-scale + ibitmap-cache make-flip flip? flip-flipped? flip-shape @@ -1070,6 +1140,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! save-image-as-bitmap skip-image-equality-fast-path + render-normalized scale-np-atomic @@ -1078,6 +1149,6 @@ the mask bitmap and the original bitmap are all together in a single bytes! image-snip->image) ;; method names -(provide get-shape get-bb get-normalized? get-normalized-shape) +(provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) (provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?) diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt index d1ad4ccf..56cea33b 100644 --- a/collects/mrlib/name-message.rkt +++ b/collects/mrlib/name-message.rkt @@ -1,11 +1,23 @@ #lang racket/gui +(define (get-left-side-padding) (+ button-label-inset circle-spacer)) +(define button-label-inset 1) +(define black-color (make-object color% "BLACK")) + +(define triangle-width 10) +(define triangle-height 14) +(define triangle-color (make-object color% 50 50 50)) + +(define border-inset 1) +(define circle-spacer 4) +(define rrect-spacer 3) + (provide/contract [get-left-side-padding (-> number?)] [pad-xywh (-> number? number? (>=/c 0) (>=/c 0) (values number? number? (>=/c 0) (>=/c 0)))] [draw-button-label - (->d ([dc (is-a?/c dc<%>)] + (->i ([dc (is-a?/c dc<%>)] [label (or/c false/c string?)] [x number?] [y number?] @@ -15,7 +27,7 @@ [grabbed? boolean?] [button-label-font (is-a?/c font%)] [bkg-color (or/c false/c (is-a?/c color%) string?)]) - #:pre-cond + #:pre (w h) (w . > . (- h (* 2 border-inset))) [result void?])] @@ -173,6 +185,7 @@ (let-values ([(w h) (get-client-size)]) (cond [hidden? + #; (let ([pen (send dc get-pen)] [brush (send dc get-brush)]) (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) @@ -214,18 +227,6 @@ (stretchable-height #f) (send (get-dc) set-smoothing 'aligned))) -(define (get-left-side-padding) (+ button-label-inset circle-spacer)) -(define button-label-inset 1) -(define black-color (make-object color% "BLACK")) - -(define triangle-width 10) -(define triangle-height 14) -(define triangle-color (make-object color% 50 50 50)) - -(define border-inset 1) -(define circle-spacer 4) -(define rrect-spacer 3) - (define (offset-color color offset-one) (make-object color% (offset-one (send color red)) @@ -261,8 +262,8 @@ circle-spacer border-inset)]) (values - (- tx (quotient (- ans-w tw) 2)) - (- ty (quotient (- ans-h th) 2)) + (- tx (quotient (ceiling (- ans-w tw)) 2)) + (- ty (quotient (ceiling (- ans-h th)) 2)) ans-w ans-h))) diff --git a/collects/mrlib/private/aligned-pasteboard/alignment.rkt b/collects/mrlib/private/aligned-pasteboard/alignment.rkt index 1e5b78f5..2741e527 100644 --- a/collects/mrlib/private/aligned-pasteboard/alignment.rkt +++ b/collects/mrlib/private/aligned-pasteboard/alignment.rkt @@ -157,7 +157,7 @@ neck and it is the most readable solution. ($ dim x width stretchable-width?) ($ dim y height stretchable-height?)) others ...) - (printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n" + (printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))\n" x width stretchable-width? y height stretchable-height?) (rect-print others)])) diff --git a/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt b/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt index 32b6b3a7..3c18771b 100644 --- a/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt +++ b/collects/mrlib/private/aligned-pasteboard/tests/debug.rkt @@ -26,12 +26,12 @@ (send snip get-margin l t r b) (printf "get-margin: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b))) - (printf "get-max-height: ~s~n" (send snip get-max-height)) - (printf "get-max-width: ~s~n" (send snip get-max-width)) - (printf "get-min-height: ~s~n" (send snip get-min-height)) - (printf "get-min-width: ~s~n" (send snip get-min-width)) - ;(printf "snip-width: ~s~n" (send pasteboard snip-width snip)) - ;(printf "snip-height: ~s~n" (send pasteboard snip-height snip)) + (printf "get-max-height: ~s\n" (send snip get-max-height)) + (printf "get-max-width: ~s\n" (send snip get-max-width)) + (printf "get-min-height: ~s\n" (send snip get-min-height)) + (printf "get-min-width: ~s\n" (send snip get-min-width)) + ;(printf "snip-width: ~s\n" (send pasteboard snip-width snip)) + ;(printf "snip-height: ~s\n" (send pasteboard snip-height snip)) )) ;;debug-pasteboard: -> (void) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 7b6b2baf..949acdcb 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -72,14 +72,8 @@ instead of this scaling code, we use the dc<%>'s scaling code. w h (* w h NUM-CHANNELS))) - (let* ([bm (make-object bitmap% w h)] - [mask (make-object bitmap% w h)] - [bdc (make-object bitmap-dc% bm)]) - (send bdc set-argb-pixels 0 0 w h bytes #f) - (send bdc set-bitmap mask) - (send bdc set-argb-pixels 0 0 w h bytes #t) - (send bdc set-bitmap #f) - (send bm set-loaded-mask mask) + (let* ([bm (make-bitmap w h)]) + (send bm set-argb-pixels 0 0 w h bytes) bm)) (define (flip-bytes bmbytes w h) diff --git a/collects/mrlib/private/image-core-snipclass.rkt b/collects/mrlib/private/image-core-snipclass.rkt new file mode 100644 index 00000000..eac28521 --- /dev/null +++ b/collects/mrlib/private/image-core-snipclass.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require racket/class) +(provide fetch image<%> + get-shape set-shape get-bb get-pinhole + get-normalized? set-normalized get-normalized-shape) + +(define-local-member-name + get-shape set-shape get-bb get-pinhole + get-normalized? set-normalized get-normalized-shape) + +(define image<%> + (interface () + get-shape set-shape get-bb get-pinhole + get-normalized? get-normalized-shape)) + +(define (fetch bytes) + (let* ([str + (and bytes + (with-handlers ((exn:fail? (λ (x) #f))) + (bytes->string/utf-8 bytes)))] + [lst (and str + (with-handlers ((exn:fail:read? (λ (x) #f))) + (racket/base:read + (open-input-string + str))))]) + (cond + [(and (list? lst) + (= 2 (length lst))) + ;; backwards compatibility for saved images that didn't have a pinhole + (list (list-ref lst 0) + (list-ref lst 1) + #f)] + [else + lst]))) + +(define racket/base:read read) diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt new file mode 100644 index 00000000..bf5d8bf1 --- /dev/null +++ b/collects/mrlib/private/regmk.rkt @@ -0,0 +1,32 @@ +#lang racket +(provide define-struct/reg-mk + id->constructor + (struct-out point) + (struct-out bb)) + +(define id-constructor-pairs '()) +(define (add-id-constructor-pair a b) + (set! id-constructor-pairs (cons (list a b) id-constructor-pairs))) + +(define-syntax (define-struct/reg-mk stx) + (syntax-case stx () + [(_ id #:reflect-id reflect-id rest ...) + (let ([build-name + (λ (fmt id) + (datum->syntax id (string->symbol (format fmt (syntax->datum id)))))]) + #`(begin + (define-struct id rest ... #:reflection-name 'reflect-id) + (add-id-constructor-pair '#,(build-name "struct:~a" #'reflect-id) + #,(build-name "make-~a" #'id))))] + [(_ id . rest) #'(define-struct/reg-mk id #:reflect-id id . rest)])) + +(define (id->constructor id) + (let ([line (assoc id id-constructor-pairs)]) + (and line + (list-ref line 1)))) + +(define-struct/reg-mk point (x y) #:transparent) + +;; a bb is (bounding box) +;; (make-bb number number number) +(define-struct/reg-mk bb (right bottom baseline) #:transparent) diff --git a/collects/mrlib/scribblings/gif.scrbl b/collects/mrlib/scribblings/gif.scrbl index 0b4916ed..84766dd9 100644 --- a/collects/mrlib/scribblings/gif.scrbl +++ b/collects/mrlib/scribblings/gif.scrbl @@ -21,8 +21,10 @@ a simple algorithm; see @scheme[quantize]. If the bitmap has a mask bitmap via @method[bitmap% get-loaded-mask], it is used to determine transparent pixels in the generated GIF image.} -@defproc[(write-animated-gif [bitmaps (listof (or/c (is-a?/c bitmap%) - (-> (is-a?/c bitmap%))))] +@defproc[(write-animated-gif [bitmaps (and/c + (listof (or/c (is-a?/c bitmap%) + (-> (is-a?/c bitmap%)))) + pair?)] [delay-csec (integer-in 0 #xFFFFFFFF)] [filename path-string] [#:loop loop? any/c (and delay-csec #t)] diff --git a/collects/mrlib/tab-choice.rkt b/collects/mrlib/tab-choice.rkt index 32ed3761..571b427d 100644 --- a/collects/mrlib/tab-choice.rkt +++ b/collects/mrlib/tab-choice.rkt @@ -46,7 +46,7 @@ [(left top) 0] [(right bottom) (- total-size item-size)] [else (error 'place-children - "alignment spec is unknown ~a~n" spec)])))]) + "alignment spec is unknown ~a\n" spec)])))]) (map (lambda (l) (let*-values ([(min-width min-height v-stretch? h-stretch?) (apply values l)] diff --git a/collects/mrlib/tex-table.rkt b/collects/mrlib/tex-table.rkt index 25c0f9d6..88a021bf 100644 --- a/collects/mrlib/tex-table.rkt +++ b/collects/mrlib/tex-table.rkt @@ -181,14 +181,14 @@ ;; checks to see if there are duplicates #; (define (find-dups) - (let ([ht (make-hash-table 'equal)]) + (let ([ht (make-hash)]) (for-each (λ (line) (let ([name (list-ref line 0)] [obj (list-ref line 1)]) - (hash-table-put! ht name (cons obj (hash-table-get ht name '()))))) + (hash-set! ht name (cons obj (hash-ref ht name '()))))) tex-shortcut-table) - (hash-table-for-each + (hash-for-each ht (λ (k v) (unless (= 1 (length v)) diff --git a/collects/scribblings/framework/framework.scrbl b/collects/scribblings/framework/framework.scrbl index 01d2b005..912ebadb 100644 --- a/collects/scribblings/framework/framework.scrbl +++ b/collects/scribblings/framework/framework.scrbl @@ -78,6 +78,14 @@ The precise set of exported names is: @racket[preferences:set-un/marshall], and @racket[preferences:restore-defaults]. } + +@item{@bold{Splash Screen} + @racket[(require @#,racketmodname[framework/splash])] + + This library provides support for a splash screen. See + @racketmodname[framework/splash] for more. +} + @item{@bold{Decorated Editor Snip} @racket[(require framework/decorated-editor-snip)] @@ -123,6 +131,7 @@ their feedback and help. @include-section["preferences-text.scrbl"] @include-section["scheme.scrbl"] @include-section["text.scrbl"] +@include-section["splash.scrbl"] @include-section["test.scrbl"] @include-section["version.scrbl"] diff --git a/collects/scribblings/framework/panel.scrbl b/collects/scribblings/framework/panel.scrbl index 19541b84..e3cd08d5 100644 --- a/collects/scribblings/framework/panel.scrbl +++ b/collects/scribblings/framework/panel.scrbl @@ -98,6 +98,12 @@ horizontally aligned. } + + @defmethod[(set-orientation [horizontal? boolean?]) void?]{ + Sets the orientation of the panel, switching it from behaving + like a @racket[panel:horizontal-dragable<%>] and + @racket[panel:vertical-dragable<%>]. + } } @definterface[panel:vertical-dragable<%> (panel:dragable<%>)]{ A panel that implements diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl new file mode 100644 index 00000000..e9dc3328 --- /dev/null +++ b/collects/scribblings/framework/splash.scrbl @@ -0,0 +1,132 @@ +#lang scribble/doc +@(require scribble/manual + (for-label racket/gui + racket/base)) +@title{Splash} +@defmodule[framework/splash] + +This module helps support applications with splash screens like the one in DrRacket. + +When this module is invoked, it sets the @racket[current-load] parameter to a procedure +that counts how many files are loaded (until @racket[shutdown-splash] is called) and uses +that number to control the gauge along the bottom of the splash screen. + +@defproc[(start-splash [draw-spec (or/c path-string? + (vector/c (or/c (-> (is-a?/c dc<%>) void?) + (-> (is-a?/c dc<%>) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)) + exact-nonnegative-integer? + exact-nonnegative-integer?))] + [splash-title string?] + [width-default exact-nonnegative-integer?] + [#:allow-funny? allow-funny? boolean? #f]) + 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}. + The progress gauge at the bottom of the window advances as files are loaded + (monitored via the @racket[current-load] parameter). + + The @racket[draw-spec] determines what the splash window contains. + The @racket[splash-title] is used as the title of the window and the @racket[width-default] determines + how many progress steps the gauge in the splash screen should + contain if there is no preference saved for the splash screen width. + The splash library uses @racket[get-preference] and @racket[put-preferences] + to store preferences, using + @racketblock[(string->symbol (format "plt:~a-splash-max-width" splash-title))] + as the key for the preference. Each time the app starts up, the maximum width + is reset based on the number of files that were loaded that time. + + If the @racket[draw-spec] is a @racket[path-string?], then the path is expected to be a file + that contains a bitmap that is drawn as the contents of the splash screen. If @racket[draw-spec] + is a vector, then the vector's first element is a procedure that is called to draw + the splash screen and the other two integers are the size of the splash screen, width followed by height. + If the procedure accepts only one argument, then it is called with a @racket[dc<%>] object where the + drawing should occur. If it accepts 5 arguments, it is called with the @racket[dc<%>], as well as + (in order) the current value of the gauge, the maximum value of the gauge, and the width and the height + of the area to draw. + + The @racket[allow-funny?] argument determines if a special gauge is used on Christmas day. + + } +@defproc[(shutdown-splash) void?]{ + Stops the splash window's gauge from advancing. Call this after all of the files have been loaded. +} + +@defproc[(close-splash) void?]{ + Closes the splash window. Call @racket[shutdown-splash] first. You can leave some time between these two + if there is more initialization work to be done where you do not want to count loaded files. +} + +@defproc[(add-splash-icon [bmp (is-a?/c bitmap%)] [x exact-nonnegative-integer?] [y exact-nonnegative-integer?]) + void?]{ + Adds an icon to the splash screen. (DrRacket uses this function to show the tools as they are loaded.) +} + +@defproc[(get-splash-bitmap) (or/c #f (is-a?/c bitmap%))]{Returns the splash bitmap unless one has not been set.} +@defproc[(set-splash-bitmap [bmp (is-a?/c bitmap%)]) void?]{ + Sets the splash bitmap to @racket[bmp] and triggers a redrawing of the splash screen. Don't use this to set + the initial bitmap, use @racket[start-splash] instead. +} +@defproc[(get-splash-canvas) (is-a?/c canvas%)]{ + Returns the canvas where the splash screen bitmap is drawn (if there is a bitmap; see @racket[start-splash] for how the splash is drawn. +} +@defproc[(get-splash-eventspace) eventspace?]{ + Returns the splash screen's eventspace. +} +@defproc[(get-splash-paint-callback) + (-> (is-a?/c dc<%>) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)]{ + Returns the callback that is invoked when redrawing the splash screen. +} +@defproc[(set-splash-paint-callback + [cb + (-> (is-a?/c dc<%>) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)]) + void?]{ + Sets the callback that is invoked when redrawing the splash screen. See @racket[start-splash] for + what the arguments are. +} +@defproc[(set-splash-progress-bar?! [b boolean?]) void?]{ + Calling this procedure with @racket[#f] removes the progress bar from the splash screen. + Useful in conjunction with setting your own paint callback for the splash screen that measures + progress in its own way, during drawing. DrRacket uses this on King Kamehameha and Prince + Kuhio day. +} +@defproc[(set-splash-char-observer [obs (-> (is-a?/c key-event%) any)]) void?]{ + Sets a procedure that is called whenever a user types a key with the splash screen as the focus. +} +@defproc[(set-splash-event-callback [obj (-> (is-?/c mouse-event%) any)]) void?]{ + Sets a procedure that is called whenever a mouse event happens in the splash canvas. } +@defproc[(get-splash-event-callback) (-> (is-?/c mouse-event%) any)]{ + Returns the last procedure passed to @racket[set-splash-event-callback] or @racket[void], if + @racket[set-splash-event-callback] has not been called. +} +@defproc[(set-refresh-splash-on-gauge-change?! [proc (-> exact-nonnegative-integer? + exact-nonnegative-integer? + any)]) + void?]{ + Sets a procedure that is called each time the splash gauge changes. If the procedure returns a true value (i.e., not @racket[#f]), + then the splash screen is redrawn. The procedure is called with the current value of the gauge and the maximum value. + + The default function is @racket[(lambda (curr tot) #f)]. +} +@defproc[(get-splash-width) exact-nonnegative-integer?]{Returns the width of the splash drawing area / bitmap. See @racket[start-splash] for the details of the size and how things are drawn.} +@defproc[(get-splash-height) exact-nonnegative-integer?]{Returns the width of the splash drawing area / bitmap. See @racket[start-splash] for the details of the size and how things are drawn.} +@defproc[(refresh-splash) void?]{ + Triggers a refresh of the splash, handling the details of double buffering + and doing the drawing on the splash's + @tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace's} + main thread. +} diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index ab838d17..74c739d8 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -1164,4 +1164,45 @@ @defclass[text:searching% (text:searching-mixin text:backup-autosave%) ()]{} @defclass[text:info% (text:info-mixin (editor:info-mixin text:searching%)) ()]{} +@definterface[text:line-numbers<%> ()]{ + + @defmethod*[(((show-line-numbers! (show boolean?)) void))]{ + + Enables or disables line number drawing. + } + + @defmethod*[(((show-line-numbers?) boolean?))]{ + + Returns whether or not line drawing is enabled. + } + + @defmethod*[(((set-line-numbers-color (color string?)) void?))]{ + + Sets the color of the line numbers. + } +} + +@defmixin[text:line-numbers-mixin (text%) (text:line-numbers<%>)]{ + + @defmethod*[#:mode override (((on-paint) void))]{ + + Draws the line numbers. + } + + @defmethod*[(((show-line-numbers! (show boolean?)) void))]{ + + Enables or disables line number drawing. + } + + @defmethod*[(((show-line-numbers?) boolean?))]{ + + Returns whether or not line drawing is enabled. + } + + @defmethod*[(((set-line-numbers-color (color string?)) void?))]{ + + Sets the color of the line numbers. + } +} + @(include-previously-extracted "main-extracts.ss" #rx"^text:") diff --git a/collects/scribblings/gui/blurbs.rkt b/collects/scribblings/gui/blurbs.rkt index 577c399e..4b4ef7eb 100644 --- a/collects/scribblings/gui/blurbs.rkt +++ b/collects/scribblings/gui/blurbs.rkt @@ -4,10 +4,19 @@ scribble/manual scribble/scheme scribble/decode - (for-label scheme/gui/base) - (for-syntax scheme/base)) + (for-label scheme/gui/base + scheme/base) + (for-syntax scheme/base) + (only-in scribblings/draw/blurbs + res-sym + Resource + ResourceFirst + boxisfill + boxisfillnull + MismatchExn)) - (provide (except-out (all-defined-out) p define-inline)) + (provide (except-out (all-defined-out) p define-inline) + (all-from-out scribblings/draw/blurbs)) (define-syntax-rule (define-inline (name) body) (define-syntax (name stx) @@ -63,7 +72,7 @@ handling an unspecified number of events; the menu may still be popped up when this method returns. If a menu item is selected from the popup-menu, the callback for the menu item is called. (The - eventspace for menu item's callback is the @|what|'s eventspace.)} + eventspace for the menu item's callback is the @|what|'s eventspace.)} @p{While the menu is popped up, its target is set to the @|other|. See @method[popup-menu% get-popup-target] @@ -152,8 +161,7 @@ information@|details|, even if the editor currently has delayed refreshing (see (define SeeMzParam @elem{(see @secref[#:doc reference-doc "parameters"])}) - (define DrawSizeNote @elem{Restrictions on the magnitude of - drawing coordinates are described with @scheme[dc<%>].}) + (define DrawSizeNote "") (define LineNumbering @elem{Lines are numbered starting with @scheme[0].}) (define ParagraphNumbering @elem{Paragraphs are numbered starting with @scheme[0].}) @@ -193,8 +201,6 @@ information@|details|, even if the editor currently has delayed refreshing (see @scheme[min-width], @scheme[min-height], @scheme[stretchable-width], and @scheme[stretchable-height] arguments, see @scheme[area<%>].}) - (define MismatchExn @elem{an @scheme[exn:fail:contract] exception is raised}) - (define AFM @elem{Adobe Font Metrics}) (define (MonitorMethod what by-what method whatsit) @@ -244,18 +250,6 @@ information@|details|, even if the editor currently has delayed refreshing (see (hspace 1) (bytes->string/latin-1 name)))) - (define (res-sym s) - (string->symbol (string-append "GRacket:" s))) - - (define (Resource s) - @elem{@to-element[`(quote ,(res-sym s))] - preference}) - (define (ResourceFirst s) ; fixme -- add index - (let ([r (Resource s)]) - (index* (list (format "~a preference" (res-sym s))) - (list r) - r))) - (define (edsnipsize a b c) @elem{An @scheme[editor-snip%] normally stretches to wrap around the size of the editor it contains. This method @|a| of the snip @@ -269,11 +263,6 @@ information@|details|, even if the editor currently has delayed refreshing (see "smaller" @elem{the editor is @|b|-aligned in the snip})) - (define (boxisfill which what) - @elem{The @|which| box is filled with @|what|.}) - (define (boxisfillnull which what) - @elem{The @|which| box is filled with @|what|, unless @|which| is @scheme[#f].}) - (define (slant . s) (make-element "slant" (decode-content s))) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 16ee2c7c..be13bbe9 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -45,11 +45,15 @@ The @scheme[style] argument indicates one or more of the following styles: @item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's bottom right when only one scrollbar is visible} - @item{@scheme['gl] --- @italic{obsolete} (every canvas is an OpenGL context where supported)} + @item{@scheme['gl] --- creates a canvas for OpenGL drawing instead of + normal @racket[dc<%>] drawing; call the @method[dc<%> + get-gl-context] method on the result of @method[canvas<%> + get-dc]; this style is usually combined with + @racket['no-autoclear]} @item{@scheme['no-autoclear] --- prevents automatic erasing of the - canvas before calls to -@method[canvas% on-paint]} + canvas before calls to @method[canvas% on-paint]} + @item{@scheme['transparent] --- the canvas is automatically ``erased'' before an update using it's parent window's background; the result is undefined if this flag is combined with @scheme['no-autoclear]} @@ -90,8 +94,9 @@ The @scheme[gl-config] argument determines properties of an OpenGL } + @defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)]) - (integer-in 1 1000000000)]{ + (integer-in 1 1000000)]{ Get the current page step size of a manual scrollbar. The result is @scheme[0] if the scrollbar is not active or it is automatic. @@ -106,7 +111,7 @@ See also @defmethod[(get-scroll-pos [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 1000000000)]{ + (integer-in 0 1000000)]{ Gets the current value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -121,7 +126,7 @@ See also @defmethod[(get-scroll-range [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 1000000000)]{ + (integer-in 0 1000000)]{ Gets the current maximum value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -163,8 +168,8 @@ Gets the size in device units of the scrollable canvas area (as } -@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 1000000000) false/c)] - [vert-pixels (or/c (integer-in 1 1000000000) false/c)] +@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 1000000) false/c)] + [vert-pixels (or/c (integer-in 1 1000000) false/c)] [h-value (real-in 0.0 1.0)] [v-value (real-in 0.0 1.0)]) void?]{ @@ -202,12 +207,12 @@ See also } -@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 1000000000) false/c)] - [v-length (or/c (integer-in 0 1000000000) false/c)] - [h-page (integer-in 1 1000000000)] - [v-page (integer-in 1 1000000000)] - [h-value (integer-in 0 1000000000)] - [v-value (integer-in 0 1000000000)]) +@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 1000000) false/c)] + [v-length (or/c (integer-in 0 1000000) false/c)] + [h-page (integer-in 1 1000000)] + [v-page (integer-in 1 1000000)] + [h-value (integer-in 0 1000000)] + [v-value (integer-in 0 1000000)]) void?]{ Enables and initializes manual scrollbars for the canvas. A @@ -248,6 +253,13 @@ See also } +@defmethod[(make-bitmap [width exact-positive-integer?] + [height exact-positive-integer?]) + (is-a/c? bitmap%)]{ + +Creates a bitmap that draws in a way that is the same as drawing to the +canvas. See also @racket[make-screen-bitmap].} + @defmethod[#:mode override (on-paint) @@ -287,9 +299,9 @@ The @scheme[h-value] and @scheme[v-value] arguments each specify a fraction of the scrollbar's movement. A @scheme[0.0] value sets the scrollbar to its left/top, while a @scheme[1.0] value sets the scrollbar to its right/bottom. A @scheme[0.5] value sets the scrollbar to its middle. In - general, if the canvas's virtual size is @scheme[v], its client size is - @scheme[c], and @scheme[(> v c)], then scrolling to @scheme[p] - sets the view start to @scheme[(floor (* p (- v c)))]. + general, if the canvas's virtual size is @scheme[_v], its client size is + @scheme[_c], and @scheme[(> _v _c)], then scrolling to @scheme[_p] + sets the view start to @scheme[(floor (* _p (- _v _c)))]. See also @method[canvas% init-auto-scrollbars] and @@ -299,7 +311,7 @@ See also @defmethod[(set-scroll-page [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 1 1000000000)]) + [value (integer-in 1 1000000)]) void?]{ Set the current page step size of a manual scrollbar. (This method has @@ -316,7 +328,7 @@ See also @defmethod[(set-scroll-pos [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 1000000000)]) + [value (integer-in 0 1000000)]) void?]{ Sets the current value of a manual scrollbar. (This method has no @@ -336,7 +348,7 @@ See also @defmethod[(set-scroll-range [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 1000000000)]) + [value (integer-in 0 1000000)]) void?]{ Sets the current maximum value of a manual scrollbar. (This method has diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index d7544a94..e802de77 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -48,6 +48,11 @@ For an @scheme[editor-canvas%] object, handling of Tab, arrow, Enter, } +@defmethod[(flush) void?]{ + +Like @racket[flush-display], but constrained if possible to the canvas.} + + @defmethod[(get-canvas-background) (or/c (is-a?/c color%) false/c)]{ Returns the color currently used to ``erase'' the canvas content before @@ -184,6 +189,12 @@ Does nothing. }} +@defmethod[(resume-flush) void?]{ + +See @method[canvas<%> suspend-flush].} + + + @defmethod[(set-canvas-background [color (is-a?/c color%)]) void?]{ @@ -209,6 +220,24 @@ Under Mac OS X, enables or disables space for a resize tab at the } + +@defmethod[(suspend-flush) void?]{ + +Drawing to a canvas's drawing context actually renders into an +offscreen buffer. The buffer is automatically flushed to the screen by +a background thread, explicitly via the @method[canvas<%> flush] method, +or explicitly via @racket[flush-display] --- unless flushing has been disabled for the canvas. +The @method[canvas<%> suspend-flush] method suspends flushing for a +canvas until a matching @method[canvas<%> resume-flush] calls; calls to +@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] can +be nested, in which case flushing is suspended until the outermost +@method[canvas<%> suspend-flush] is balanced by a @method[canvas<%> +resume-flush]. + +On some platforms, beware that suspending flushing for a canvas can +discourage refreshes for other windows in the same frame.} + + @defmethod[(warp-pointer [x (integer-in 0 10000)] [y (integer-in 0 10000)]) void?]{ diff --git a/collects/scribblings/gui/combo-field-class.scrbl b/collects/scribblings/gui/combo-field-class.scrbl index c2b0a74f..14b54d5f 100644 --- a/collects/scribblings/gui/combo-field-class.scrbl +++ b/collects/scribblings/gui/combo-field-class.scrbl @@ -5,8 +5,8 @@ A @scheme[combo-field%] object is a @scheme[text-field%] object that also resembles a @scheme[choice%] object, because it - has a small popup button to the right of the text field. By default, - clicking the button pops up a menu, and selecting a menu item copies + has a small popup button to the right of the text field. Clicking + the button pops up a menu, and selecting a menu item typically copies the item into the text field. @@ -40,9 +40,8 @@ The @scheme[choices] list specifies the initial list of items for the combo's popup menu. The @method[combo-field% append] method adds a new item to the menu with a callback to install the appended item into the combo's text field. The -@method[combo-field% get-menu] method returns the combo's menu to allow arbitrary other operations. - This menu might not be used at all if -@method[combo-field% on-popup] is overridden. +@method[combo-field% get-menu] method returns a menu that can be changed to + adjust the content and actions of the combo's menu. The @scheme[callback] procedure is called when the user changes the text in the combo or presses the Enter key (and Enter is not handled by @@ -75,11 +74,10 @@ Adds a new item to the combo's popup menu. The given label is used for @defmethod[(get-menu) (is-a?/c popup-menu%)]{ -Returns the @scheme[popup-menu%] that is used by the default -@method[combo-field% on-popup] method. This menu is initialized with the @scheme[labels] argument when - the @scheme[combo-field%] is created, and the -@method[combo-field% append] method adds a new item to the menu. - +Returns a @scheme[popup-menu%] that is effectively copied into the + combo's popup menu when the combo is clicked. Only the labels can + callbacks of the menu's items are used; the enable state, submenus, + or separators are ignored. } @@ -88,14 +86,13 @@ Returns the @scheme[popup-menu%] that is used by the default @methspec{ -Called when the user clicks the combo's popup button. +Called when the user clicks the combo's popup button. Override this method +to adjust the content of the combo menu on demand. } @methimpl{ -Gets a menu from -@method[combo-field% get-menu], sets its minimum width to match the combo control's width, and - then pops up the menu. +Does nothing. }} diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 98f5e55d..15df4329 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -16,7 +16,9 @@ A dialog is a top-level window that is @defterm{modal}: while the [height (or/c (integer-in 0 10000) false/c) #f] [x (or/c (integer-in 0 10000) false/c) #f] [y (or/c (integer-in 0 10000) false/c) #f] - [style (listof (one-of/c 'no-caption 'resize-border 'no-sheet)) null] + [style (listof (one-of/c 'no-caption 'resize-border + 'no-sheet 'close-button)) + null] [enabled any/c #t] [border (integer-in 0 1000) 0] [spacing (integer-in 0 1000) 0] @@ -68,6 +70,9 @@ The @scheme[style] flags adjust the appearance of the dialog on some @item{@scheme['no-sheet] --- uses a movable window for the dialog, even if a parent window is provided (Mac OS X)} + @item{@scheme['close-button] --- include a close button in the + dialog's title bar, which would not normally be included (Mac OS X)} + ] Even if the dialog is not shown, a few notification events may be diff --git a/collects/scribblings/gui/dynamic.scrbl b/collects/scribblings/gui/dynamic.scrbl index b0f35c3f..2e4e52f8 100644 --- a/collects/scribblings/gui/dynamic.scrbl +++ b/collects/scribblings/gui/dynamic.scrbl @@ -5,21 +5,17 @@ @title{Dynamic Loading} @defmodule[racket/gui/dynamic]{The @racketmodname[racket/gui/dynamic] -library provides functions for dynamically accessing the Racket -GUI toolbox, instead of directly requiring @racket[racket/gui] or -@racket[racket/gui/base].} +library provides functions for dynamically accessing the +@racketmodname[racket/gui/base] library, instead of directly requiring +@racketmodname[racket/gui] or @racketmodname[racket/gui/base].} @defproc[(gui-available?) boolean?]{ -Returns @racket[#t] if dynamic access to the GUI bindings are -available---that is, that the program is being run as a -GRacket-based application, as opposed to a pure -Racket-based application, and that GUI modules are attached -to the namespace in which @racket[racket/gui/dynamic] was -instantiated. - -This predicate can be used in code that optionally uses GUI elements -when they are available.} +Returns @racket[#t] if dynamic access to the GUI bindings is +available. The bindings are available if +@racketmodname[racket/gui/base] has been loaded, instantiated, and +attached to the namespace in which @racket[racket/gui/dynamic] was +instantiated.} @defproc[(gui-dynamic-require [sym symbol?]) any]{ diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index 9a25dc9c..f0bf8589 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -71,7 +71,7 @@ The @scheme[style] list can contain the following flags: method} @item{@scheme['transparent] --- the canvas is ``erased'' before an - update using it's parent window's background} + update using its parent window's background} ] diff --git a/collects/scribblings/gui/editor-funcs.scrbl b/collects/scribblings/gui/editor-funcs.scrbl index d378d873..24dd7864 100644 --- a/collects/scribblings/gui/editor-funcs.scrbl +++ b/collects/scribblings/gui/editor-funcs.scrbl @@ -213,7 +213,8 @@ Opens @racket[filename] (in @racket['binary] mode) and checks whether it looks [end-position (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [snip-filter ((is-a?/c snip%) . -> . any/c) (lambda (s) s)] [port-name any/c text-editor] - [expect-to-read-all? any/c #f]) + [expect-to-read-all? any/c #f] + [#:lock-while-reading? lock-while-reading? any/c #f]) input-port]{ Creates an input port that draws its content from @racket[text-editor]. @@ -252,7 +253,10 @@ The result port must not be used if @racket[text-editor] changes in any @method[snip-admin% recounted]). The @method[text% get-revision-number] method can be used to detect any of these changes. - +To help guard against such uses, if @racket[lock-while-reading?] argument is +a true value, then @racket[open-input-text-editor] will lock the @racket[text-editor] +before it returns and unlock it after it is safe to use the above methods. (In some +cases, it will not lock the editor at all, if using those methods are always safe.) } diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 5134b7e2..8a75d461 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -959,7 +959,11 @@ The @scheme[show-errors?] argument is no longer used. @defmethod[(insert-image [filename (or/c path-string? #f) #f] - [type (or/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict) 'unknown] + [type (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict) + 'unknown/alpha] [relative-path? any/c #f] [inline? any/c #t]) void?]{ @@ -1006,8 +1010,8 @@ See also @method[editor<%> insert-file]. @defmethod[(invalidate-bitmap-cache [x real? 0.0] [y real? 0.0] - [width (or/c (and/c real? (not/c negative?)) 'end) 'end] - [height (or/c (and/c real? (not/c negative?)) 'end) 'end]) + [width (or/c (and/c real? (not/c negative?)) 'end 'display-end) 'end] + [height (or/c (and/c real? (not/c negative?)) 'end 'display-end) 'end]) void?]{ When @method[editor<%> on-paint] is overridden, call this method when @@ -1018,7 +1022,13 @@ The @scheme[x], @scheme[y], @scheme[width], and @scheme[height] coordinates. If @scheme[width]/@scheme[height] is @scheme['end], then the total height/width of the editor (as reported by @method[editor<%> get-extent]) is used. Note that the editor's size - can be smaller than the visible region of its @techlink{display}. + can be smaller than the visible region of its @techlink{display}. If + @scheme[width]/@scheme[height] is @scheme['display-end], then the + largest height/width of the editor's views (as reported by + @method[editor-admin% get-max-view]) is used. If + @scheme[width]/@scheme[height] is not @scheme['display-end], then + the given @scheme[width]/@scheme[height] is constrained to the + editor's size. The default implementation triggers a redraw of the editor, either immediately or at the end of the current edit sequence (if any) @@ -1515,7 +1525,10 @@ Creates a @scheme[editor-snip%] with either a sub-editor from @defmethod[(on-new-image-snip [filename path?] - [kind (or/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)] + [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict)] [relative-path? any/c] [inline? any/c]) (is-a?/c image-snip%)]{ @@ -1543,7 +1556,9 @@ Returns @scheme[(make-object image-snip% filename kind relative-path? inline?)]. [bottom real?] [dx real?] [dy real?] - [draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)]) + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))]) void?]{ @methspec{ @@ -1882,7 +1897,9 @@ See also @method[editor<%> add-undo]. [y real?] [width (and/c real? (not/c negative?))] [height (and/c real? (not/c negative?))] - [draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)] + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))] [background (or/c (is-a?/c color%) #f)]) void?]{ diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 7bfd5d60..bc0c15bf 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -2,7 +2,7 @@ @(require scribble/bnf "common.ss") -@title[#:tag "editor-overview"]{Editor} +@title[#:tag "editor-overview"]{Editors} The editor toolbox provides a foundation for two common kinds of applications: @@ -601,8 +601,8 @@ When an editor contains other editors, it keeps track of caret appropriate sub-editor. When an editor or snip is drawn, an argument to the drawing method - specifies whether the caret should be drawn with the data. This - argument can be any of (in increasing order): + specifies whether the caret should be drawn with the data or whether + a selection spans the data. This argument can be any of: @itemize[ @@ -616,6 +616,11 @@ When an editor or snip is drawn, an argument to the drawing method @item{@indexed-scheme['show-caret] --- The caret should be drawn to show keyboard focus ownership.} + @item{@racket[(cons _start _end)] --- The caret is owned by an + enclosing region, and its selection spans the current editor or snip; + in the case of the snip, the selection spans elements @racket[_start] + through @racket[_end] positions within the snip.} + ] The @scheme['show-inactive-caret] display mode is useful for showing @@ -715,11 +720,10 @@ An editor is not tied to any particular thread or eventspace, except to the degree that it is displayed in a canvas (which has an eventspace). Concurrent access of an editor is always safe, in the sense that the editor will not become corrupted. However, because - editor access can trigger locks, and because lock-rejected operations - tend to fail silently, concurrent access can produce unexpected - results. + editor access can trigger locks, concurrent access can produce + contract failures or unexpected results. -Nevertheless, the editor supports certain concurrent patterns +An editor supports certain concurrent patterns reliably. One relevant pattern is updating an editor in one thread while the editor is displayed in a canvas that is managed by a different (handler) thread. To ensure that canvas refreshes are not diff --git a/collects/scribblings/gui/font-funcs.scrbl b/collects/scribblings/gui/font-funcs.scrbl index 74923e89..3eef2d2d 100644 --- a/collects/scribblings/gui/font-funcs.scrbl +++ b/collects/scribblings/gui/font-funcs.scrbl @@ -3,28 +3,6 @@ @title{Fonts} - -@defproc[(get-face-list [family (one-of/c 'mono 'all) 'all]) - (listof string?)]{ - -Returns a list of font face names available on the current system. If - @scheme['mono] is provided as the argument, then only faces that are - known to correspond to monospace fonts are included in the list. - -} - -@defproc[(get-family-builtin-face [family (one-of/c 'default 'decorative 'roman 'script - 'swiss 'modern 'symbol 'system)]) - string?]{ - -Returns the built-in default face mapping for a particular font - family. The built-in default can be overridden via preferences, as - described in @secref["fontresources"]. - -See @scheme[font%] for information about @scheme[family]. - -} - @defthing[menu-control-font (is-a?/c font%)]{ This font is the default for @scheme[popup-menu%] objects. diff --git a/collects/scribblings/gui/frame-class.scrbl b/collects/scribblings/gui/frame-class.scrbl index 927307c6..7fac78e1 100644 --- a/collects/scribblings/gui/frame-class.scrbl +++ b/collects/scribblings/gui/frame-class.scrbl @@ -87,7 +87,8 @@ some platforms: frame's title bar (Mac OS X); a click on the toolbar button triggers a call to @method[frame% on-toolbar-button-click]} @item{@scheme['hide-menu-bar] --- hides the menu bar and dock when - the frame is active (Mac OS X)} + the frame is active (Mac OS X) or asks the window manager to make + the frame fullscreen (X)} @item{@scheme['float] --- causes the frame to stay in front of all other non-floating windows (Windows and Mac OS X always, X when diff --git a/collects/scribblings/gui/gauge-class.scrbl b/collects/scribblings/gui/gauge-class.scrbl index a5f1ea3d..cd672922 100644 --- a/collects/scribblings/gui/gauge-class.scrbl +++ b/collects/scribblings/gui/gauge-class.scrbl @@ -11,7 +11,7 @@ of the gauge. @defconstructor[([label (or/c label-string? false/c)] - [range (integer-in 1 10000)] + [range (integer-in 1 1000000)] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] [style (listof (one-of/c 'horizontal 'vertical diff --git a/collects/scribblings/gui/global-draw-funcs.scrbl b/collects/scribblings/gui/global-draw-funcs.scrbl index 0ff0932f..d8f77670 100644 --- a/collects/scribblings/gui/global-draw-funcs.scrbl +++ b/collects/scribblings/gui/global-draw-funcs.scrbl @@ -6,11 +6,13 @@ @defproc[(flush-display) void?]{ -Under X and Mac OS X, flushes pending display messages such that the - user's display reflects the actual state of the windows. Under - Windows, the procedure has no effect. +Flushes canvas offscreen drawing and other updates onto the + screen. + +Normally, drawing is automatically flushed to the screen. Use +@racket[flush-display] sparingly to force updates to the screen when +other actions depend on updating the display.} -} @defproc[(get-display-depth) exact-nonnegative-integer?]{ @@ -57,44 +59,3 @@ Returns @scheme[#t] if the main display has color, @scheme[#f] otherwise. } - -@defproc[(register-collecting-blit [canvas (is-a?/c canvas%)] - [x real?] - [y real?] - [w (and/c real? (not/c negative?))] - [h (and/c real? (not/c negative?))] - [on (is-a?/c bitmap%)] - [off (is-a?/c bitmap%)] - [on-x real? 0] - [on-y real? 0] - [off-x real? 0] - [off-y real? 0]) - void?]{ - -Registers a blit to occur when garbage collection starts or ends. - -When garbage collection starts, @scheme[(send (send canvas #,(:: - canvas<%> get-dc)) #,(:: dc<%> draw-bitmap-section) on on-x on-y x y w - h)] is called. When garbage collection ends, @scheme[(send (send - canvas #,(:: canvas<%> get-dc)) #,(:: dc<%> draw-bitmap-section) off - off-x off-y x y w h)] is called. If @scheme[canvas]'s device context - has a scale, the scale may or may not be temporarily disabled during - the bitmap drawing. - -The @scheme[canvas] is registered weakly, so it will be automatically - unregistered if the canvas becomes invisible and inaccessible. - Multiple registrations can be installed for the same canvas. - -See also @scheme[unregister-collecting-blit]. - -} - -@defproc[(unregister-collecting-blit [canvas (is-a?/c canvas%)]) - void?]{ - -Unregisters a blit request installed with See also - @scheme[register-collecting-blit]. - -Unregisters all blits for @scheme[canvas]. - -} diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 707b1017..b51741fe 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -1,50 +1,54 @@ #lang scribble/doc @(require "common.ss") -@title{@bold{GUI}: Racket Graphics Toolkit} +@title{@bold{GUI}: Racket Graphical Interface Toolkit} @author["Matthew Flatt" "Robert Bruce Findler" "John Clements"] @declare-exporting[racket/gui/base racket/gui #:use-sources (mred)] -This reference manual describes the GUI toolbox that is part of Racket - and whose core is implemented by the GRacket executable. - @defmodule*/no-declare[(racket/gui/base)]{The @racketmodname[racket/gui/base] library provides all of the class, -interface, and procedure bindings defined in this manual. At run time, -this library needs primitive graphics support that the GRacket executable -provides; this library cannot run inside the Racket executable.} +interface, and procedure bindings defined in this manual, in addition +to the bindings of @racketmodname[racket/draw].} @defmodulelang*/no-declare[(racket/gui)]{The @racketmodname[racket/gui] language combines all bindings of the @racketmodname[racket] language and the -@racketmodname[racket/gui/base] modules.} +@racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} +The @racketmodname[racket/gui] toolbox is roughly organized into two +parts: + +@itemize[ + + @item{The @deftech{windowing toolbox}, for implementing windows, + buttons, menus, text fields, and other controls.} + + @item{The @deftech{editor toolbox}, for developing traditional text + editors, editors that mix text and graphics, or free-form layout + editors (such as a word processor, HTML editor, or icon-based file + browser).} + +] + +Both parts of the toolbox rely extensively on the +@racketmodname[racket/draw] drawing library. @table-of-contents[] @;------------------------------------------------------------------------ -@include-section["guide.scrbl"] -@include-section["reference.scrbl"] -@include-section["config.scrbl"] +@include-section["win-overview.scrbl"] +@include-section["win-classes.scrbl"] +@include-section["win-funcs.scrbl"] +@include-section["editor-overview.scrbl"] +@include-section["editor-classes.scrbl"] +@include-section["editor-funcs.scrbl"] +@include-section["wxme.scrbl"] +@include-section["prefs.scrbl"] @include-section["dynamic.scrbl"] - -@;------------------------------------------------------------------------ - -@(bibliography - - (bib-entry #:key "Adobe99" - #:author "Adobe Systems Incorporated" - #:title "PostScript Language Reference, third edition" - #:is-book? #t - #:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf" - #:date "1999") - - ) - @;------------------------------------------------------------------------ @index-section[] diff --git a/collects/scribblings/gui/guide.scrbl b/collects/scribblings/gui/guide.scrbl index 451958a3..25d27029 100644 --- a/collects/scribblings/gui/guide.scrbl +++ b/collects/scribblings/gui/guide.scrbl @@ -3,35 +3,6 @@ @title[#:style '(toc reveal)]{Overview} -For documentation purposes, the graphics toolbox is organized into - three parts: - -@itemize[ - - @item{The @deftech{windowing toolbox}, for implementing form-filling - GUI programs (such as a database query window) using buttons, menus, - text fields, and events. The windowing toolbox is described in - @secref["windowing-overview"].} - - @item{The @deftech{drawing toolbox}, for drawing pictures or - implementing dynamic GUI programs (such as a video game) using - drawing canvases, pens, and brushes. The drawing toolbox is - described in @secref["drawing-overview"].} - - @item{The @deftech{editor toolbox}, for developing traditional text - editors, editors that mix text and graphics, or free-form layout - editors (such as a word processor, HTML editor, or icon-based file - browser). The editor toolbox is described in - @secref["editor-overview"].} - -] - -These three parts roughly represent layers of increasing - sophistication. Simple GUI programs access only the windowing toolbox - directly, more complex programs use both the windowing and drawing - toolboxes, and large-scale applications rely on all three - toolboxes. - @local-table-of-contents[] @;------------------------------------------------------------------------ @@ -40,8 +11,4 @@ These three parts roughly represent layers of increasing @;------------------------------------------------------------------------ -@include-section["draw-overview.scrbl"] - -@;------------------------------------------------------------------------ - @include-section["editor-overview.scrbl"] diff --git a/collects/scribblings/gui/image-snip-class.scrbl b/collects/scribblings/gui/image-snip-class.scrbl index 5d34edf3..aa45b9c0 100644 --- a/collects/scribblings/gui/image-snip-class.scrbl +++ b/collects/scribblings/gui/image-snip-class.scrbl @@ -9,9 +9,9 @@ An @scheme[image-snip%] is a snip that can display bitmap images @defconstructor*/make[(([filename (or/c path-string? false/c) #f] - [kind (one-of/c 'unknown 'unknown/mask - 'gif 'gif/mask - 'jpeg 'png 'png/mask + [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha 'xbm 'xpm 'bmp 'pict) 'unknown] [relative-path? any/c #f] [inline? any/c #t]) @@ -95,9 +95,10 @@ relative to the owning editor's path}] } @defmethod[(get-filetype) - (one-of/c 'unknown 'unknwon/mask - 'gif 'gif/mask - 'jpeg 'png 'png/mask 'xbm 'xpm 'bmp 'pict)]{ + (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict)]{ Returns the kind used to load the currently loaded, non-inlined file, or @scheme['unknown] if a file is not loaded or if a file was loaded @@ -106,9 +107,9 @@ Returns the kind used to load the currently loaded, non-inlined file, } @defmethod[(load-file [filename (or/c path-string? false/c)] - [kind (one-of/c 'unknown 'unknown/mask - 'gif 'gif/mask - 'jpeg 'png 'png/mask + [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha 'xbm 'xpm 'bmp 'pict) 'unknown] [relative-path? any/c #f] [inline? any/c #t]) diff --git a/collects/scribblings/gui/key-event-class.scrbl b/collects/scribblings/gui/key-event-class.scrbl index 9e0ddf41..6a9957a4 100644 --- a/collects/scribblings/gui/key-event-class.scrbl +++ b/collects/scribblings/gui/key-event-class.scrbl @@ -164,9 +164,10 @@ The special key symbols attempt to capture useful keys that have no If a suitable special key symbol or ASCII representation is not available, @scheme[#\nul] (the NUL character) is reported. -Under X, a @scheme['wheel-up] or @scheme['wheel-down] event may be sent - to a window other than the one with the keyboard focus, because X - generates wheel events based on the location of the mouse pointer. +A @scheme['wheel-up] or @scheme['wheel-down] event may be sent to a + window other than the one with the keyboard focus, because some + platforms generate wheel events based on the location of the mouse + pointer instead of the keyboard focus. Under Windows, when the Control key is pressed without Alt, the key code for ASCII characters is downcased, roughly cancelling the effect diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index c32cf3a2..99c4335e 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -56,8 +56,8 @@ The get operation always returns @racket[#"????"] and @racket[#"????"] for Windows. } -@defproc[(find-graphical-system-path [what (one-of/c 'init-file 'setup-file 'x-display)]) - (or/c path? false/c)]{ +@defproc[(find-graphical-system-path [what (one-of/c 'init-file 'x-display)]) + (or/c path? #f)]{ Finds a platform-specific (and possibly user- or machine-specific) standard filename or directory. See also @racket[find-system-path]. @@ -75,13 +75,10 @@ The result depends on @racket[what], and a @racket[#f] result is only @itemize[ @item{@|AllUnix|: @indexed-file{.gracketrc}} - @item{Windows: @indexed-file{racketrc.rktl}} + @item{Windows: @indexed-file{gracketrc.rktl}} ]} - @item{@racket['setup-file] returns the path to the file - containing resources used by @racket[get-resource]; obsolete.} - @item{@racket['x-display] returns a ``path'' whose string identifies the X display if specified by either the @Flag{display} flag or the @envvar{DISPLAY} environment variable when GRacket starts under X. For @@ -110,64 +107,26 @@ default is @racket['(cmd)]. Under X, the default is normally @defproc[(get-panel-background) (is-a?/c color%)]{ -Returns the background color of a panel (usually some shade of gray) - for the current platform. +Returns a shade of gray. +Historically, the result matched the color of +a @racket[panel%] background, but @racket[panel%] backgrounds can vary +on some platforms (e.g., when nested in a @racket[group-box-panel%]), +so the result is no longer guaranteed to be related to a +@racket[panel%]'s color. } -@defproc[(get-resource [section string?] - [entry string?] - [value (box/c (or/c string? exact-integer?))] - [file (or/c path? false/c) #f]) - boolean?]{ -Gets a resource value from the resource database. The resource value - is keyed on the combination of @racket[section] and @racket[entry]. The - return value is @racket[#t] if a value is found, @racket[#f] if it is - not. The type of the value initially in the @racket[value] box - determines the way that the resource is interpreted, and @racket[value] - is filled with a new value of the same type if one is found. +@defproc[(get-highlight-background-color) (is-a?/c color%)]{ -If @racket[file] is @racket[#f], platform-specific resource files - are read, as determined by @racket[find-graphical-system-path] - with @indexed-racket['setup-file]. (Under X, when @racket[file] is - @racket[#f], the user's @filepath{.Xdefaults} file is also read, or the - file specified by the @filepath{XENVIRONMENT} environment variable.) +Returns the color that is drawn behind selected text.} -The format of a resource entry depends on the platform. Windows - resources use the standard @filepath{.ini} format. X and Mac OS X - resources use the standard X resource format, where each entry - consists of a @racket[section].@racket[entry] resource name, a colon, and - the resource value, terminated by a newline. Section and entry names are - case-sensitive. -@index['("registry")]{@index['("Windows registry")]{Under}} Windows, if - @racket[section] is one of the following strings, then @racket[file] - is ignored, and @racket[entry] is used as a resource path: +@defproc[(get-highlight-text-color) (or/c (is-a?/c color%) #f)]{ -@itemize[ +Returns the color that is used to draw selected text or @racket[#f] if +selected text is drawn with its usual color.} - @item{@indexed-racket["HKEY_CLASSES_ROOT"]} - @item{@indexed-racket["HKEY_CURRENT_CONFIG"]} - @item{@indexed-racket["HKEY_CURRENT_USER"]} - @item{@indexed-racket["HKEY_LOCAL_MACHINE"]} - @item{@indexed-racket["HKEY_USERS"]} - -] - -In that case, the @racket[entry] argument is parsed as a resource entry -path, followed by a backslash, followed by a value name. To get the -``default'' value for an entry, use the empty name. For example, the -following expression gets a command line for starting a browser: - -@racketblock[ -(let ([b (box "")]) - (get-resource "HKEY_CLASSES_ROOT" - "htmlfile\\shell\\open\\command\\" b) - (unbox b)) -] - -See also @racket[write-resource].} @defproc[(get-window-text-extent [string string] [font (is-a?/c font%)] @@ -264,6 +223,20 @@ Strips shortcut ampersands from @racket[label], removes parenthesized } +@defproc[(make-gl-bitmap [width exact-positive-integer?] + [height exact-positive-integer?] + [config (is-a?/c gl-config%)]) + (is-a/c? bitmap%)]{ + +Creates a bitmap that supports both normal @racket[dc<%>] drawing an +OpenGL drawing through a context returned by @xmethod[dc<%> get-gl-context]. + +For @racket[dc<%>] drawing, an OpenGL-supporting bitmap draws like a +bitmap frmo @racket[make-screen-bitmap] on some platforms, while it +draws like a bitmap instantiated directly from @racket[bitmap%] on +other platforms.} + + @defproc[(make-gui-empty-namespace) namespace?]{ Like @racket[make-base-empty-namespace], but with @@ -277,6 +250,17 @@ Like @racket[make-base-namespace], but with @racketmodname[racket/class] and environment of the result namespace.} +@defproc[(make-screen-bitmap [width exact-positive-integer?] + [height exact-positive-integer?]) + (is-a/c? bitmap%)]{ + +Creates a bitmap that draws in a way that is the same as drawing to a +canvas in its default configuration. + +A normal @racket[bitmap%] draws in a more platform-independent way and +may use fewer constrained resources, particularly under Windows.} + + @defproc[(play-sound [filename path-string?] [async? any/c]) boolean?]{ @@ -305,77 +289,49 @@ Under X, the function invokes an external sound-playing program; Under Mac OS X, Quicktime is used to play sounds; most sound formats (.wav, .aiff, .mp3) are supported in recent versions of Quicktime. In order to play .wav files, Quicktime 3.0 (compatible - with OS 7.5 and up) is required. + with OS 7.5 and up) is required.} +@defproc[(register-collecting-blit [canvas (is-a?/c canvas%)] + [x real?] + [y real?] + [w (and/c real? (not/c negative?))] + [h (and/c real? (not/c negative?))] + [on (is-a?/c bitmap%)] + [off (is-a?/c bitmap%)] + [on-x real? 0] + [on-y real? 0] + [off-x real? 0] + [off-y real? 0]) + void?]{ -} +Registers a ``blit'' to occur when garbage collection starts and + ends. When garbage collection starts, @racket[on] is drawn at + location @racket[x] and @racket[y] within @racket[canvas], if + @racket[canvas] is shown. When garbage collection ends, the drawing + is reverted, possibly by drawing the @racket[off] bitmap. + +The background behind @racket[on] is unspecified, so @racket[on] + should be a solid image, and the canvas's scale or scrolling is not + applied to the drawing. Only the portion of @racket[on] within + @racket[w] and @racket[h] pixels is used; if @racket[on-x] and + @racket[on-y] are specified, they specify an offset within the bitmap + that is used for drawing, and @racket[off-x] and @racket[off-y] + similarly specify an offset within @racket[off]. + +The blit is automatically unregistered if @scheme[canvas] becomes + invisible and inaccessible. Multiple registrations can be installed + for the same @scheme[canvas]. + +See also @scheme[unregister-collecting-blit].} -@defproc[(send-event [receiver-bytes (lambda (s) (and (bytes? s) - (= 4 (bytes-length s))))] - [event-class-bytes (lambda (s) (and (bytes? s) - (= 4 (bytes-length s))))] - [event-id-bytes (lambda (s) (and (bytes? s) - (= 4 (bytes-length s))))] - [direct-arg-v any/c (void)] - [argument-list list? null]) - any/c]{ +@defproc[(unregister-collecting-blit [canvas (is-a?/c canvas%)]) + void?]{ -Sends an AppleEvent or raises @racket[exn:fail:unsupported]. +Unregisters all blit requests installed for @racket[canvas] with + @scheme[register-collecting-blit].} -The @racket[receiver-bytes], @racket[event-class-bytes], and -@racket[event-id-bytes] arguments specify the signature of the -receiving application, the class of the AppleEvent, and the ID of -the AppleEvent. - -The @racket[direct-arg-v] value is converted (see below) and passed as -the main argument of the event; if @racket[direct-argument-v] is -@|void-const|, no main argument is sent in the event. The -@racket[argument-list] argument is a list of two-element lists -containing a typestring and value; each typestring is used ad the -keyword name of an AppleEvent argument for the associated converted -value. - -The following types of Racket values can be converted to AppleEvent -values passed to the receiver: - -@atable[ -(tline @elem{@racket[#t] or @racket[#f]} @elem{Boolean}) -(tline @elem{small integer} @elem{Long Integer}) -(tline @elem{inexact real number} @elem{Double}) -(tline @elem{string} @elem{Characters}) -(tline @elem{list of convertible values} @elem{List of converted values}) -(tline @racket[#(file _pathname)] @elem{Alias (file exists) or FSSpec (does not exist)}) -(tline @racket[#(record (_typestring _v) ...)] @elem{Record of keyword-tagged values}) -] - -If other types of values are passed to @racket[send-event] for - conversion, the @exnraise[exn:fail:unsupported]. - -The @racket[send-event] procedure does not return until the receiver -of the AppleEvent replies. The result of @racket[send-event] is the -reverse-converted reply value (see below), or the @exnraise[exn:fail] -if there is an error. If there is no error or return value, -@racket[send-event] returns @|void-const|. - -The following types of AppleEvent values can be reverse-converted into -a Racket value returned by @racket[send-event]: - -@atable[ -(tline @elem{Boolean} @elem{@racket[#t] or @racket[#f]}) -(tline @elem{Signed Integer} @elem{integer}) -(tline @elem{Float, Double, or Extended} @elem{inexact real number}) -(tline @elem{Characters} @elem{string}) -(tline @elem{List of reverse-convertible values} @elem{list of reverse-converted values}) -(tline @elem{Alias or FSSpec} @racket[#(file _pathname)]) -(tline @elem{Record of keyword-tagged values} @racket[#(record (_typestring _v) ...)]) -] - -If the AppleEvent reply contains a value that cannot be - reverse-converted, the @exnraise[exn:fail]. - -} @defproc[(send-message-to-window [x (integer-in -10000 10000)] [y (integer-in -10000 10000)] @@ -415,33 +371,16 @@ See @racket[clipboard<%>]. } -@defproc[(write-resource [section string?] - [entry string?] - [value (or/c string? exact-integer?)] - [file (or/c path-string? false/c) #f]) - boolean?]{ - -Writes a resource value to the specified resource database. The - resource value is keyed on the combination of @racket[section] and - @racket[entry], with the same special handling of @racket[entry] for - under Windows as for @racket[get-resource]. - -If @racket[file] is @racket[#f], the platform-specific resource - database is read, as determined by - @racket[find-graphical-system-path] with - @indexed-racket['setup-file]. - -The return value is @racket[#t] if the write succeeds, @racket[#f] - otherwise. (A failure indicates that the resource file cannot be - written.) - -If @racket[value] is an integer outside a platform-specific range, - @|MismatchExn|. - -See also @racket[get-resource].} - @defproc[(label-string? [v any/c]) boolean?]{ - Returns @racket[#t] if @racket[v] is a string whose length is less than or equal to @racket[200]. + Returns @racket[#t] if @racket[v] is a string whose length is less than or equal to @racket[200]. + + This predicate is typically used as the contract for strings that + appear in GUI objects. In some cases, such as the label in a @racket[button%] + or @racket[menu-item%] object, the character @litchar{&} is treated specially + to indicate that the following character is used in keyboard navigation. See + @xmethod[labelled-menu-item<%> set-label] for one such example. + In other cases, such as the label on a @racket[frame%], @litchar{&} is not + treated specially. } @defproc[(key-code-symbol? [v any/c]) boolean?]{ diff --git a/collects/scribblings/gui/mouse-event-class.scrbl b/collects/scribblings/gui/mouse-event-class.scrbl index 4ba715b8..9c9d2129 100644 --- a/collects/scribblings/gui/mouse-event-class.scrbl +++ b/collects/scribblings/gui/mouse-event-class.scrbl @@ -148,7 +148,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button Returns the type of the event; see @scheme[mouse-event%] for information about each event type. See also @method[mouse-event% -set-event-type] . +set-event-type]. } @@ -260,7 +260,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button void?]{ Sets the type of the event; see @scheme[mouse-event%] for information -about each event type. See also @method[mouse-event% get-event-type] . +about each event type. See also @method[mouse-event% get-event-type]. } diff --git a/collects/scribblings/gui/prefs.scrbl b/collects/scribblings/gui/prefs.scrbl index 0bc67865..ae694426 100644 --- a/collects/scribblings/gui/prefs.scrbl +++ b/collects/scribblings/gui/prefs.scrbl @@ -20,11 +20,6 @@ The following are the (case-sensitive) preference names used by GRacket: the basic style in a style list, and thus the default font size for an editor.} - @item{@ResourceFirst{controlFontSize} --- sets the font size for - control and menu labels (Windows, X); the font is the @scheme['system] - font, which can be configured as described in - @secref["fontresources"].} - @item{@ResourceFirst{defaultMenuPrefix} --- sets the prefix used by default for menu item shortcuts under X, one of @scheme['ctl], @scheme['meta], or @scheme['alt]. The default is @@ -32,25 +27,10 @@ The following are the (case-sensitive) preference names used by GRacket: @scheme['alt], underlined mnemonics (introduced by @litchar{&} in menu labels) are suppressed.} - @item{@ResourceFirst{altUpSelectsMenu} --- a true value makes - pressing and releasing the Alt key select the first menu in the menu - bar under X.} - @item{@ResourceFirst{emacsUndo} --- a true value makes undo in editors work as in Emacs (i.e., undo operations are themselves kept in the undo stack).} - @item{@ResourceFirst{hiliteColor} --- a string to sets the color for - highlighting text, menus, and other GUI elements under X; the - preference string should contain six hexadecimal digits, two for each - component of the color. For example, set @Resource{hiliteColor} to - @scheme["0000A0"] and set @Resource{hiliteMenuBorder} to @scheme[#t] - for a Bluecurve-like look.} - - @item{@ResourceFirst{hiliteMenuBorder} --- a true value causes a menu - selection to be highlighted with a border (in addition to a color) under - X.} - @item{@ResourceFirst{wheelStep} --- sets the default mouse-wheel step size of @scheme[editor-canvas%] objects.} @@ -61,26 +41,8 @@ The following are the (case-sensitive) preference names used by GRacket: @item{@ResourceFirst{playcmd} --- used to format a sound-playing command; see @scheme[play-sound] for details.} - @item{@ResourceFirst{forceFocus} --- a true value enables extra - effort in GRacket to move the focus to a top-level window that is shown - or raised.} - @item{@ResourceFirst{doubleClickTime} --- overrides the platform-specific default interval (in milliseconds) for double-click events.} - @item{@ResourceFirst{gamma} --- sets the gamma value used in - gamma-correcting PNG files.} - - @item{@ResourceFirst{selectionAsClipboard} --- under X, a true value - causes @scheme[the-clipboard] to be an alias to - @scheme[the-x-selection-clipboard], which means that cut and paste - operations use the X selection instead of the X clipboard. See also - @scheme[clipboard<%>].} - - ] - -In addition, preference names built from font face names can provide - or override default entries for the @scheme[font-name-directory<%>]; - see @secref["fontresources"] for information. diff --git a/collects/scribblings/gui/printer-dc-class.scrbl b/collects/scribblings/gui/printer-dc-class.scrbl index e6078bfd..f75220bd 100644 --- a/collects/scribblings/gui/printer-dc-class.scrbl +++ b/collects/scribblings/gui/printer-dc-class.scrbl @@ -3,13 +3,10 @@ @defclass/title[printer-dc% object% (dc<%>)]{ -A @scheme[printer-dc%] object is a Windows or Mac OS X printer - device context. The class cannot be instantiated under X (an - @scheme[exn:misc:unsupported] exception is raised). - -Under Mac OS X, a newly created @scheme[printer-dc%] object obtains - orientation (portrait versus landscape) and scaling information from - the current @scheme[ps-setup%] object, as determined by the +A @scheme[printer-dc%] object is a printer device context. A newly + created @scheme[printer-dc%] object obtains orientation (portrait + versus landscape) and scaling information from the current + @scheme[ps-setup%] object, as determined by the @scheme[current-ps-setup] parameter. This information can be configured by the user through a dialog shown by @scheme[get-page-setup-from-user]. diff --git a/collects/scribblings/gui/reference.scrbl b/collects/scribblings/gui/reference.scrbl index a6cf354a..707a646f 100644 --- a/collects/scribblings/gui/reference.scrbl +++ b/collects/scribblings/gui/reference.scrbl @@ -7,8 +7,6 @@ @include-section["win-classes.scrbl"] @include-section["win-funcs.scrbl"] -@include-section["draw-classes.scrbl"] -@include-section["draw-funcs.scrbl"] @include-section["editor-classes.scrbl"] @include-section["editor-funcs.scrbl"] @include-section["wxme.scrbl"] diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl index dd590f4a..33b5c46c 100644 --- a/collects/scribblings/gui/snip-class.scrbl +++ b/collects/scribblings/gui/snip-class.scrbl @@ -170,7 +170,9 @@ Called when the snip's editor's method is called, [bottom real?] [dx real?] [dy real?] - [draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)]) + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))]) void?]{ @methspec{ @@ -187,7 +189,11 @@ The @scheme[dx] and @scheme[dy] argument provide numbers that can be editor coordinates (as opposed to DC coordinates, which are used for drawing). -See @|drawcaretdiscuss| for information about @scheme[draw-caret]. +See @|drawcaretdiscuss| for information about +@scheme[draw-caret]. When @racket[draw-caret] is a pair, refrain from +drawing a background for the selected region, and use +@racket[get-highlight-text-color] when it is not @racket[#f] for +drawing text and other ``foreground'' elements. Before this method is called, the correct font, text color, and pen color for the snip's style will have been set in the drawing context diff --git a/collects/scribblings/gui/system-menu-funcs.scrbl b/collects/scribblings/gui/system-menu-funcs.scrbl index 43904445..5051b9e4 100644 --- a/collects/scribblings/gui/system-menu-funcs.scrbl +++ b/collects/scribblings/gui/system-menu-funcs.scrbl @@ -113,7 +113,9 @@ When the current eventspace is the initial eventspace, this procedure The default handler queues a callback to the @method[window<%> on-drop-file] method of the most-recently activated frame in the main eventspace (see @scheme[get-top-level-edit-target-window]), if - drag-and-drop is enabled for that frame. + drag-and-drop is enabled for that frame. Otherwise, it saves + the filename and re-queues the handler event when the application + file handler is later changed. When the application is @italic{not} running and user double-clicks an application-handled file or drags a file onto the application's icon, diff --git a/collects/scribblings/gui/text-field-class.scrbl b/collects/scribblings/gui/text-field-class.scrbl index 3519d102..3032ca10 100644 --- a/collects/scribblings/gui/text-field-class.scrbl +++ b/collects/scribblings/gui/text-field-class.scrbl @@ -116,6 +116,11 @@ For a text field, the most useful methods of a @scheme[text%] object } +@defmethod[(get-field-background) (is-a?/c color%)]{ + +Gets the background color of the field's editable area.} + + @defmethod[(get-value) string?]{ @@ -124,6 +129,12 @@ Returns the text currently in the text field. } +@defmethod[(set-field-background [color (is-a?/c color%)]) + void?]{ + +Sets the background color of the field's editable area.} + + @defmethod[(set-value [val string?]) void?]{ diff --git a/collects/scribblings/gui/win-classes.scrbl b/collects/scribblings/gui/win-classes.scrbl index ee89b352..afa5b9ed 100644 --- a/collects/scribblings/gui/win-classes.scrbl +++ b/collects/scribblings/gui/win-classes.scrbl @@ -57,6 +57,7 @@ Alphabetical: @include-section["pane-class.scrbl"] @include-section["panel-class.scrbl"] @include-section["popup-menu-class.scrbl"] +@include-section["printer-dc-class.scrbl"] @include-section["radio-box-class.scrbl"] @include-section["selectable-menu-item-intf.scrbl"] @include-section["separator-menu-item-class.scrbl"] diff --git a/collects/scribblings/gui/win-funcs.scrbl b/collects/scribblings/gui/win-funcs.scrbl index 248d79bb..70bb4e72 100644 --- a/collects/scribblings/gui/win-funcs.scrbl +++ b/collects/scribblings/gui/win-funcs.scrbl @@ -8,4 +8,6 @@ @include-section["dialog-funcs.scrbl"] @include-section["eventspace-funcs.scrbl"] @include-section["system-menu-funcs.scrbl"] +@include-section["global-draw-funcs.scrbl"] +@include-section["font-funcs.scrbl"] @include-section["miscwin-funcs.scrbl"] diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index 1b632b55..45ad0a0a 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -5,11 +5,19 @@ @title[#:tag "windowing-overview"]{Windowing} -The Racket windowing toolbox provides the basic building blocks of GUI +The windowing toolbox provides the basic building blocks of GUI programs, including frames (top-level windows), modal dialogs, menus, - buttons, check boxes, text fields, and radio buttons. The toolbox - provides these building blocks via built-in classes, such as the - @scheme[frame%] class: + buttons, check boxes, text fields, and radio buttons---all as + classes. + +@margin-note{See @secref["classes" #:doc '(lib +"scribblings/guide/guide.scrbl")] for an introduction to classes and +interfaces in Racket.} + +@section{Creating Windows} + +To create a new top-level window, instantiate the @scheme[frame%] + class: @schemeblock[ (code:comment @#,t{Make a frame by instantiating the @scheme[frame%] class}) @@ -21,7 +29,7 @@ The Racket windowing toolbox provides the basic building blocks of GUI The built-in classes provide various mechanisms for handling GUI events. For example, when instantiating the @scheme[button%] class, - the programmer supplies an event callback procedure to be invoked + supply an event callback procedure to be invoked when the user clicks the button. The following example program creates a frame with a text message and a button; when the user clicks the button, the message changes: @@ -46,18 +54,18 @@ The built-in classes provide various mechanisms for handling GUI ] Programmers never implement the GUI event loop directly. Instead, the - system automatically pulls each event from an internal queue and + windowing system automatically pulls each event from an internal queue and dispatches the event to an appropriate window. The dispatch invokes the window's callback procedure or calls one of the window's - methods. In the above program, the system automatically invokes the + methods. In the above program, the windowing system automatically invokes the button's callback procedure whenever the user clicks @onscreen{Click Me}. If a window receives multiple kinds of events, the events are dispatched to methods of the window's class instead of to a callback procedure. For example, a drawing canvas receives update events, - mouse events, keyboard events, and sizing events; to handle them, a - programmer must derive a new class from the built-in + mouse events, keyboard events, and sizing events; to handle them, + derive a new class from the built-in @scheme[canvas%] class and override the event-handling methods. The following expression extends the frame created above with a canvas that handles mouse and keyboard events: @@ -86,10 +94,10 @@ After running the above code, manually resize the frame to see the on-event]. While the canvas has the keyboard focus, typing on the keyboard invokes the canvas's @method[canvas<%> on-char] method. -The system dispatches GUI events sequentially; that is, after invoking - an event-handling callback or method, the system waits until the +The windowing system dispatches GUI events sequentially; that is, after invoking + an event-handling callback or method, the windowing system waits until the handler returns before dispatching the next event. To illustrate the - sequential nature of events, we extend the frame again, adding a + sequential nature of events, extend the frame again, adding a @onscreen{Pause} button: @schemeblock[ @@ -99,7 +107,7 @@ The system dispatches GUI events sequentially; that is, after invoking ] After the user clicks @onscreen{Pause}, the entire frame becomes - unresponsive for five seconds; the system cannot dispatch more events + unresponsive for five seconds; the windowing system cannot dispatch more events until the call to @scheme[sleep] returns. For more information about event dispatching, see @secref["eventspaceinfo"]. @@ -111,7 +119,7 @@ In addition to dispatching events, the GUI classes also handle the as a frame, arranges its children in a column, and a horizontal container arranges its children in a row. A container can be a child of another container; for example, to place two buttons side-by-side - in our frame, we create a horizontal panel for the new buttons: + in our frame, create a horizontal panel for the new buttons: @schemeblock[ (define panel (new horizontal-panel% [parent frame])) @@ -128,6 +136,49 @@ In addition to dispatching events, the GUI classes also handle the For more information about window layout and containers, see @secref["containeroverview"]. + +@section[#:tag "canvas-drawing"]{Drawing in Canvases} + +The content of a canvas is determined by its @method[canvas% on-paint] +method, where the default @method[canvas% on-paint] calls the +@racket[paint-callback] function that is supplied when the canvas is +created. The @method[canvas% on-paint] method receives no arguments +and uses the canvas's @method[canvas<%> get-dc] method to obtain a +@tech[#:doc '(lib "scribblings/draw/draw.scrbl")]{drawing context} +(DC) for drawing; the default @method[canvas% on-paint] method passes +the canvas and this DC on to the @racket[paint-callback] function. +Drawing operations of the @racket[racket/draw] toolbox on the DC are +reflected in the content of the canvas onscreen. + +For example, the following program creates a canvas +that displays large, friendly letters: + +@schemeblock[ +(define frame (new frame% + [label "Example"] + [width 300] + [height 300])) +(new canvas% [parent frame] + [paint-callback + (lambda (canvas dc) + (send dc #,(:: dc<%> set-scale) 3 3) + (send dc #,(:: dc<%> set-text-foreground) "blue") + (send dc #,(:: dc<%> draw-text) "Don't Panic!" 0 0))]) +(send frame #,(:: top-level-window<%> show) #t) +] + +The background color of a canvas can be set through the +@method[canvas<%> set-canvas-background] method. To make the canvas +transparent (so that it takes on its parent's color and texture as its +initial content), supply @racket['transparent] in the @racket[style] +argument when creating the canvas. + +See @secref["overview" #:doc '(lib "scribblings/draw/draw.scrbl")] in +@other-doc['(lib "scribblings/draw/draw.scrbl")] for an overview of +drawing with the @racket[racket/draw] library. For more advanced +information on canvas drawing, see @secref["animation"]. + + @section{Core Windowing Classes} The fundamental graphical element in the windowing toolbox is an @@ -328,7 +379,7 @@ The built-in container classes include horizontal panels (and panes), which align their children in a row, and vertical panels (and panes), which align their children in a column. By nesting horizontal and vertical containers, a programmer can achieve most any layout. For - example, we can construct a dialog with the following shape: + example, to construct a dialog with the shape @verbatim[#:indent 2]{ ------------------------------------------------------ @@ -654,10 +705,9 @@ Whenever the user moves the mouse, clicks or releases a mouse button, target window. A program can use the @method[window<%> focus] method to move the focus to a subwindow or to set the initial focus. - Under X, a @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] + A @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] event may be sent to a window other than the one with the keyboard - focus, because X generates wheel events based on the location of the - mouse pointer. + focus, depending on how the operating system handles wheel events. A key-press event may correspond to either an actual key press or an auto-key repeat. Multiple key-press events without intervening @@ -942,3 +992,34 @@ This expression installs an exception handler that prints an error handler during the call to @scheme[yield], an error message is printed before control returns to the event dispatcher within @scheme[yield]. + + +@section[#:tag "animation"]{Animation in Canvases} + +The content of a canvas is buffered, so if a canvas must be redrawn, +the @method[canvas% on-paint] method or @racket[paint-callback] function +usually does not need to be called again. To further reduce flicker, +while the @method[canvas% on-paint] method or @racket[paint-callback] function +is called, the windowing system avoids flushing the canvas-content +buffer to the screen. + +Canvas content can be updated at any time by drawing with the result +of the canvas's @method[canvas<%> get-dc] method, and drawing is +thread-safe. Changes to the canvas's content are flushed to the screen +periodically (not necessarily on an event-handling boundary), but the +@method[canvas<%> flush] method immediately flushes to the screen---as +long as flushing has not been suspended. The @method[canvas<%> +suspend-flush] and @method[canvas<%> resume-flush] methods suspend and +resume both automatic and explicit flushes, although on some +platforms, automatic flushes are forced in rare cases. + +For most animation purposes, @method[canvas<%> suspend-flush], +@method[canvas<%> resume-flush], and @method[canvas<%> flush] can be +used to avoid flicker and the need for an additional drawing buffer +for animations. During an animation, bracket the construction of each +animation frame with @method[canvas<%> suspend-flush] and +@method[canvas<%> resume-flush] to ensure that partially drawn frames +are not flushed to the screen. Use @method[canvas<%> flush] to ensure +that canvas content is flushed when it is ready if a @method[canvas<%> +suspend-flush] will soon follow, because the process of flushing to +the screen can be starved if flushing is frequently suspend. diff --git a/collects/scribblings/gui/wxme.scrbl b/collects/scribblings/gui/wxme.scrbl index c165b806..36f2f5d5 100644 --- a/collects/scribblings/gui/wxme.scrbl +++ b/collects/scribblings/gui/wxme.scrbl @@ -165,10 +165,12 @@ in a @tech{WXME} stream. The interface has two methods: Called at most once per @tech{WXME} stream to initialize the data type's stream-specific information. This method usually does nothing.} -@defmethod[(read-snip [text-only? Boolean?] +@defmethod[(read-snip [text-only? boolean?] [version exact-nonnegative-integer?] [stream (is-a?/c stream<%>)]) - any/c]{ + (if text-only? + bytes? + any/c)]{ Called when an instance of the data type is encountered in the stream. This method reads the data and returns either bytes to be diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 60f808df..591d3f28 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -13,9 +13,9 @@ gracket to exit in order to pass, this governor is required. To run a test use: - framework-test ... + framework-test ... -where is the name of one of the tests below. Alternatively, +where is the name of one of the tests below. Alternatively, pass no command-line arguments to run all of the tests. Some of the tests in this file are not yet present in the @@ -26,17 +26,17 @@ OS X: you will have to click on the newly started gracket processes in the doc while the test suite runs or it will signal failures when there aren't any. -- load: |# load.ss #| +- load: |# load.rkt #| | This tests that the advertised ways of loading the framework at | it's components all work. -- exit: |# exit.ss #| +- exit: |# exit.rkt #| | This tests that exit:exit really exits and that the exit callbacks | are actually run. -- preferences: |# prefs.ss #| +- preferences: |# prefs.rkt #| | This tests that preferences are saved and restored correctly, both | immediately and across reboots of gracket. @@ -48,20 +48,20 @@ signal failures when there aren't any. | Each test assumes that the others pass; this may yield strange | error messages when one fails. - - frames: |# frame.ss #| - - canvases: |# canvas.ss #| - - texts: |# text.ss #| - - pasteboards: |# pasteboard.ss #| + - frames: |# frame.rkt #| + - canvases: |# canvas.rkt #| + - texts: |# text.rkt #| + - pasteboards: |# pasteboard.rkt #| -- keybindings: |# keys.ss #| +- keybindings: |# keys.rkt #| | This tests the misc (non-scheme) keybindings -- searching: |# search.ss #| +- searching: |# search.rkt #| | This tests the search results -- group tests: |# group-test.ss #| +- group tests: |# group-test.rkt #| | make sure that mred:the-frame-group records frames correctly. | fake user input expected. @@ -75,15 +75,15 @@ signal failures when there aren't any. | Tests the scheme: section - |# scheme.ss #| + |# scheme.rkt #| - |# (interactive #| tests | these tests require intervention by people. Clicking and whatnot - - panel:single |# panel.ss #| + - panel:single |# panel.rkt #| - - garbage collection: |# mem.ss #| + - garbage collection: |# mem.rkt #| | These tests will create objects in various configurations and | make sure that they are garbage collected diff --git a/collects/tests/framework/framework-test b/collects/tests/framework/framework-test index 645de72e..d7a8b640 100755 --- a/collects/tests/framework/framework-test +++ b/collects/tests/framework/framework-test @@ -1,4 +1,4 @@ -#!/bin/bash +#!/bin/sh # {{{ here # Make this PATH-independent diff --git a/collects/tests/framework/keys.rkt b/collects/tests/framework/keys.rkt index 3d244263..2ff6c5fa 100644 --- a/collects/tests/framework/keys.rkt +++ b/collects/tests/framework/keys.rkt @@ -80,16 +80,50 @@ (test-canonicalize 11 "esc;s:a" "esc;s:a") (test-canonicalize 12 "s:a;esc" "s:a;esc") + + ;; a key-spec is (make-key-spec buff-spec buff-spec (listof ?) (listof ?) (listof ?)) + ;; a key-spec represents a test case for a key; 'before' contains the + ;; content of a buffer, and 'after' represents the desired content of the + ;; buffer after the keypress. The keypress(es) in question are specified + ;; independently for the three platforms by the respective 'macos', 'unix', + ;; and 'windows' fields. (define-struct key-spec (before after macos unix windows)) + + ;; an abstraction to use when all platforms have the same sequence of keys + (define (make-key-spec/allplatforms before after keys) + (make-key-spec before after keys keys keys)) + + ;; a buff-spec is (make-buff-spec string nat nat) + ;; a buff-spec represents a buffer state; the content of the buffer, + ;; and the start and end of the highlighted region. (define-struct buff-spec (string start end)) + ;; the keybindings test cases applied to frame:text% editors (define global-specs (list (make-key-spec (make-buff-spec "abc" 1 1) (make-buff-spec "abc" 2 2) - (list '(#\f control) '(right)) - (list '(#\f control) '(right)) - (list '(#\f control) '(right))))) + (list '((#\f control)) '((right))) + (list '((#\f control)) '((right))) + (list '((#\f control)) '((right)))) + + ;; TeX-compress tests + (make-key-spec/allplatforms + (make-buff-spec "\\ome" 4 4) + (make-buff-spec "ω" 1 1) + '(((#\\ control)))) + (make-key-spec/allplatforms + (make-buff-spec "\\sub" 4 4) + (make-buff-spec "\\subset" 7 7) + '(((#\\ control)))) + (make-key-spec/allplatforms + (make-buff-spec "\\subset" 7 7) + (make-buff-spec "⊂" 1 1) + '(((#\\ control)))) + (make-key-spec/allplatforms + (make-buff-spec "\\sub" 4 4) + (make-buff-spec "⊆" 1 1) + '(((#\\ control) (#\e) (#\\ control)))))) (define (build-open-bracket-spec str pos char) (make-key-spec (make-buff-spec str pos pos) @@ -99,22 +133,23 @@ (substring str pos (string-length str))) (+ pos 1) (+ pos 1)) - (list (list #\[)) - (list (list #\[)) - (list (list #\[)))) + (list (list (list #\[))) + (list (list (list #\[))) + (list (list (list #\[))))) + ;; the keybindings test cases applied to scheme:text% editors (define scheme-specs (list (make-key-spec (make-buff-spec "(abc (def))" 4 4) (make-buff-spec "(abc (def))" 10 10) - (list '(right alt)) - (list '(right alt)) - (list '(right alt))) + (list '((right alt))) + (list '((right alt))) + (list '((right alt)))) (make-key-spec (make-buff-spec "'(abc (def))" 1 1) (make-buff-spec "'(abc (def))" 12 12) - (list '(right alt)) - (list '(right alt)) - (list '(right alt))) + (list '((right alt))) + (list '((right alt))) + (list '((right alt)))) #| (make-key-spec (make-buff-spec "'(abc (def))" 0 0) (make-buff-spec "'(abc (def))" 12 12) @@ -159,36 +194,105 @@ (build-open-bracket-spec "(let ([])(" 10 #\() (build-open-bracket-spec "(local " 7 #\[) (build-open-bracket-spec "(local []" 9 #\() + ;; test to show that multi-keystrokes works: + (make-key-spec/allplatforms + (make-buff-spec "" 0 0) + (make-buff-spec "zx" 2 2) + (list '((#\z) (#\x)))) + ;; remove-enclosing-parens : + (make-key-spec/allplatforms + (make-buff-spec "(abc def)" 1 1) + (make-buff-spec "abc" 0 0) + (list '((#\c control) (#\o control)))) + ;; (is this the desired behavior?): + (make-key-spec/allplatforms + (make-buff-spec "(abc def)" 2 3) + (make-buff-spec "bc" 0 0) + (list '((#\c control) (#\o control)))) + ;; insert-()-pair : + (make-key-spec + (make-buff-spec "abc" 0 0) + (make-buff-spec "()abc" 1 1) + (list '((escape) (#\())) + (list '((#\( meta))) + (list '((escape) (#\()))) + (make-key-spec + (make-buff-spec "abc" 0 2) + (make-buff-spec "(ab)c" 1 1) + (list '((escape) (#\())) + (list '((#\( meta))) + (list '((escape) (#\()))) + ;; toggle-square-round-parens : + ; () -> [] + (make-key-spec/allplatforms + (make-buff-spec "(a)" 0 0) + (make-buff-spec "[a]" 0 0) + (list '((#\c control) (#\[ control)))) + ; [] -> () + (make-key-spec/allplatforms + (make-buff-spec "[a]" 0 0) + (make-buff-spec "(a)" 0 0) + (list '((#\c control) (#\[ control)))) + ; enclosed sexps + (make-key-spec/allplatforms + (make-buff-spec "[a (def )b]" 0 0) + (make-buff-spec "(a (def )b)" 0 0) + (list '((#\c control) (#\[ control)))) + ; extra preceding whitespace + (make-key-spec/allplatforms + (make-buff-spec " \n [a (def )b]" 0 0) + (make-buff-spec " \n (a (def )b)" 0 0) + (list '((#\c control) (#\[ control)))) + ; cursor not at beginning of buffer + (make-key-spec/allplatforms + (make-buff-spec " \n [a (def )b]" 1 1) + (make-buff-spec " \n (a (def )b)" 1 1) + (list '((#\c control) (#\[ control)))) + ; intervening non-paren sexp + (make-key-spec/allplatforms + (make-buff-spec " \nf [a (def )b]" 1 1) + (make-buff-spec " \nf [a (def )b]" 1 1) + (list '((#\c control) (#\[ control)))) + ;; at end of buffer (hence sexp-forward returns #f): + (make-key-spec/allplatforms + (make-buff-spec "[a]" 3 3) + (make-buff-spec "[a]" 3 3) + (list '((#\c control) (#\[ control)))) )) (send-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t)) (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) (wait-for-frame "dummy to trick frame group") + ;; test-key : key-spec -> + ;; evaluates a test case represented as a key-spec (define (test-key key-spec) - (let* ([keys ((case (system-type) - [(macos macosx) key-spec-macos] - [(unix) key-spec-unix] - [(windows) key-spec-windows]) - key-spec)] + (let* ([key-sequences + ((case (system-type) + [(macos macosx) key-spec-macos] + [(unix) key-spec-unix] + [(windows) key-spec-windows]) + key-spec)] [before (key-spec-before key-spec)] [after (key-spec-after key-spec)] - [process-key - (lambda (key) + [process-key-sequence + (lambda (key-sequence) (let ([text-expect (buff-spec-string after)] [start-expect (buff-spec-start after)] [end-expect (buff-spec-end after)]) - (test key + (test key-sequence (lambda (x) (equal? x (vector text-expect start-expect end-expect))) `(let* ([text (send (get-top-level-focus-window) get-editor)]) (send text erase) (send text insert ,(buff-spec-string before)) (send text set-position ,(buff-spec-start before) ,(buff-spec-end before)) - (test:keystroke ',(car key) ',(cdr key)) + ,@(map (lambda (key) `(test:keystroke ',(car key) ',(cdr key))) + key-sequence) (vector (send text get-text) (send text get-start-position) (send text get-end-position))))))]) - (for-each process-key keys))) + (for-each process-key-sequence key-sequences))) + (define (test-specs frame-name frame-class specs) (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t)) @@ -196,7 +300,7 @@ (for-each test-key specs) (send-sexp-to-mred `(send (get-top-level-focus-window) close))) - (test-specs "global keybingings test" 'frame:text% global-specs) + (test-specs "global keybindings test" 'frame:text% global-specs) (test-specs "scheme mode keybindings test" '(class frame:editor% (define/override (get-editor%) scheme:text%) diff --git a/collects/tests/framework/main.rkt b/collects/tests/framework/main.rkt index d94f3a78..b1e3bb24 100644 --- a/collects/tests/framework/main.rkt +++ b/collects/tests/framework/main.rkt @@ -48,7 +48,10 @@ "framework-test" (current-command-line-arguments) command-line-flags (lambda (collected . files) (when (null? files) (set! batch? #t)) - (let ([files (filter (lambda (x) (member x all-files)) files)]) + (let* ([throwouts (remove* all-files files)] + [files (remove* throwouts files)]) + (when (not (null? throwouts)) + (debug-printf admin " ignoring files that don't occur in all-files: ~s\n" throwouts)) (set! files-to-process (cond [all? all-files] [batch? (remove* interactive-files all-files)] diff --git a/collects/tests/framework/scheme.rkt b/collects/tests/framework/scheme.rkt index c31c5cc6..6f5129a6 100644 --- a/collects/tests/framework/scheme.rkt +++ b/collects/tests/framework/scheme.rkt @@ -21,10 +21,11 @@ (test-text-balanced? 0 "" 0 #f #f) (test-text-balanced? 1 " \n " 0 #f #f) -(test-text-balanced? 2 "foo)" 0 #f #f) +(test-text-balanced? 2 "foo)" 0 #f #t) (test-text-balanced? 3 "(foo" 0 #f #f) (test-text-balanced? 4 "(foo)" 0 #f #t) -(test-text-balanced? 5 "(foo 'bar))" 0 #f #f) +(test-text-balanced? 5 "(foo 'bar))" 0 #f #t) (test-text-balanced? 6 "(foo) bar ([buz])" 0 #f #t) -(test-text-balanced? 7 "(foo]" 0 #f #f) +(test-text-balanced? 7 "(foo]" 0 #f #t) (test-text-balanced? 8 "{foo} ((bar) [5.9])" 0 #f #t) +(test-text-balanced? 9 "#(1 2 . 3)" 0 #f #t) diff --git a/collects/tests/gracket/combo-steps.txt b/collects/tests/gracket/combo-steps.txt new file mode 100644 index 00000000..80a569cd --- /dev/null +++ b/collects/tests/gracket/combo-steps.txt @@ -0,0 +1,12 @@ +Set Up, Callbacks, Appending +---------------------------- + +The choice/list should contain "Apple" and "Banana" for + starters. + +Watch for "Popup!" printed to stdout when you click the choice item. + +When you use "Reset", the content should change to "Alpha", "Beta", + and "Gamma", and selecting them should install the word plus + "for Reset" into the text field. + diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 2ce39dbe..7213989f 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -20,7 +20,11 @@ (send-generic mdc (make-generic (object-interface mdc) m) . args) (error 'bad-dc "~a shouldn't succeed" `(send ,m ...)))) -(define (test-all mdc try) +(define (good m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args)) + +(define (test-all mdc try try-ok) + (try 'erase) (try 'clear) (try 'draw-arc 0 0 10 10 0.1 0.2) (try 'draw-bitmap bm2 0 0) @@ -40,35 +44,49 @@ (try 'end-page) (try 'end-doc) - (try 'get-background) - (try 'get-brush) - (try 'get-clipping-region) - (try 'get-font) - (try 'get-pen) (try 'get-size) - (try 'get-text-background) - (try 'get-text-foreground) - (try 'get-text-mode) - (try 'set-background (make-object color% "Yellow")) - (try 'set-brush (make-object brush% "Yellow" 'solid)) - (try 'set-clipping-rect 0 0 10 10) - (try 'set-clipping-region (make-object region% mdc)) - (try 'set-font (make-object font% 12 'default 'normal 'normal)) - (try 'set-origin 0 0) - (try 'set-pen (make-object pen% "Yellow" 1 'solid)) - (try 'set-scale 2 2) - (try 'set-text-background (make-object color% "Yellow")) - (try 'set-text-foreground (make-object color% "Yellow")) - (try 'set-text-mode 'transparent) + (try-ok 'get-background) + (try-ok 'get-brush) + (try-ok 'get-clipping-region) + (try-ok 'get-font) + (try-ok 'get-pen) + (try-ok 'get-text-background) + (try-ok 'get-text-foreground) + (try-ok 'get-text-mode) + (try-ok 'get-alpha) + (try-ok 'get-scale) + (try-ok 'get-origin) + (try-ok 'get-rotation) + + (try-ok 'set-background (make-object color% "Yellow")) + (try-ok 'set-brush (make-object brush% "Yellow" 'solid)) + (try-ok 'set-clipping-rect 0 0 10 10) + (try-ok 'set-clipping-region (make-object region% mdc)) + (try-ok 'set-font (make-object font% 12 'default 'normal 'normal)) + (try-ok 'set-origin 0 0) + (try-ok 'set-pen (make-object pen% "Yellow" 1 'solid)) + (try-ok 'set-scale 2 2) + (try-ok 'set-alpha 0.75) + (try-ok 'set-text-background (make-object color% "Yellow")) + (try-ok 'set-text-foreground (make-object color% "Yellow")) + (try-ok 'set-text-mode 'transparent) + + (try-ok 'get-char-height) + (try-ok 'get-char-width) + (try 'try-color (make-object color% "Yellow") (make-object color%))) (st #f mdc ok?) -(test-all mdc bad) +(test-all mdc bad good) (send mdc set-bitmap bm) -(test-all mdc (lambda (m . args) - (send-generic mdc (make-generic (object-interface mdc) m) . args))) + +(test-all mdc + (lambda (m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args)) + (lambda (m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args))) (send mdc set-bitmap #f) @@ -179,6 +197,27 @@ #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0"))) (test #t 'same-bits (equal? bs bs2))) +;; ---------------------------------------- +;; Test draw-bitmap-section-smooth + +(let* ([bm (make-bitmap 100 100)] + [dc (make-object bitmap-dc% bm)] + [bm2 (make-bitmap 70 70)] + [dc2 (make-object bitmap-dc% bm2)] + [bm3 (make-bitmap 70 70)] + [dc3 (make-object bitmap-dc% bm3)]) + (send dc draw-ellipse 0 0 100 100) + (send dc2 draw-bitmap-section-smooth bm + 10 10 50 50 + 0 0 100 100) + (send dc3 scale 0.5 0.5) + (send dc3 draw-bitmap bm 20 20) + (let ([s2 (make-bytes (* 4 70 70))] + [s3 (make-bytes (* 4 70 70))]) + (send bm2 get-argb-pixels 0 0 70 70 s2) + (send bm3 get-argb-pixels 0 0 70 70 s3) + (test #t 'same-scaled (equal? s2 s3)))) + ;; ---------------------------------------- (report-errs) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index d4b8fbf3..3d8158cb 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -191,6 +191,11 @@ (send dc set-bitmap #f) bm)) +(define (show-error . args) + (with-handlers ([exn? (lambda (exn) + (printf "~a\n" (exn-message exn)))]) + (apply error args))) + (define DRAW-WIDTH 550) (define DRAW-HEIGHT 375) @@ -221,7 +226,9 @@ [save-filename #f] [save-file-format #f] [clip 'none] - [current-alpha 1.0]) + [current-alpha 1.0] + [current-rotation 0.0] + [current-skew? #f]) (send hp0 stretchable-height #f) (send hp stretchable-height #f) (send hp2.5 stretchable-height #f) @@ -255,8 +262,8 @@ (override* [on-paint (case-lambda - [() (on-paint #f)] - [(ps?) + [() (time (on-paint #f))] + [(kind) (let* ([can-dc (get-dc)] [pen0s (make-object pen% "BLACK" 0 'solid)] [pen1s (make-object pen% "BLACK" 1 'solid)] @@ -657,11 +664,11 @@ (case mask-ex-mode [(plt plt-mask plt^plt mred^plt) (let* ([plt (get-plt)] - [tmp-bm (make-object bitmap% - (send mred-icon get-width) - (send mred-icon get-height) - #f)] - [tmp-dc (make-object bitmap-dc% tmp-bm)]) + [ww (send mred-icon get-width)] + [hh (send mred-icon get-height)] + [tmp-bm (make-object bitmap% ww hh #f)] + [tmp-dc (make-object bitmap-dc% tmp-bm)] + [mask-bm tmp-bm]) (send tmp-dc draw-bitmap plt (/ (- (send mred-icon get-width) (send plt get-width)) @@ -669,16 +676,33 @@ (/ (- (send mred-icon get-height) (send plt get-height)) 2)) + (when (memq mask-ex-mode '(plt^plt mred^plt)) + ;; Convert to grayscale + (let ([s (make-bytes (* 4 ww hh))]) + (send tmp-bm get-argb-pixels 0 0 ww hh s) + (for* ([i (in-range 0 ww)] + [j (in-range 0 hh)]) + (let* ([p (* 4 (+ (* j ww) i))] + [v (quotient (+ (bytes-ref s (+ p 1)) + (bytes-ref s (+ p 2)) + (bytes-ref s (+ p 3))) + 3)]) + (bytes-set! s (+ p 1) v) + (bytes-set! s (+ p 2) v) + (bytes-set! s (+ p 3) v))) + (set! mask-bm (make-object bitmap% ww hh #f)) + (send tmp-dc set-bitmap mask-bm) + (send tmp-dc set-argb-pixels 0 0 ww hh s))) (if (eq? mask-ex-mode 'mred^plt) (send dc draw-bitmap mred-icon x y 'solid (send the-color-database find-color "BLACK") - tmp-bm) + mask-bm) (send dc draw-bitmap tmp-bm x y 'solid (send the-color-database find-color "BLACK") (cond [(eq? mask-ex-mode 'plt-mask) mred-icon] - [(eq? mask-ex-mode 'plt^plt) tmp-bm] + [(eq? mask-ex-mode 'plt^plt) mask-bm] [else #f]))))] [(mred^mred) (send dc draw-bitmap mred-icon x y @@ -716,7 +740,7 @@ 0 0 w h mode color) (set! x (+ x w 10)))) - (printf "bad bitmap~n")))]) + (printf "bad bitmap\n")))]) ;; BB icon (do-one bb 'solid black) (let ([start x]) @@ -724,7 +748,7 @@ (do-one return 'solid black) (do-one return 'solid red) (do-one return 'opaque red) - ;; Next three, on a bluew background + ;; Next three, on a blue background (let ([end x] [b (send dc get-brush)]) (send dc set-brush (make-object brush% "BLUE" 'solid)) @@ -787,7 +811,7 @@ (send dc draw-rectangle 180 205 20 20) (send dc set-brush brushs)))) - (when (and pixel-copy? last? (not (or ps? (eq? dc can-dc)))) + (when (and pixel-copy? last? (not (or kind (eq? dc can-dc)))) (let* ([x 100] [y 170] [x2 245] [y2 188] @@ -917,7 +941,7 @@ (send dc draw-rectangle 187 310 20 20) (send dc set-pen p))) - (when (and last? (not (or ps? (eq? dc can-dc))) + (when (and last? (not (or kind (eq? dc can-dc))) (send mem-dc get-bitmap)) (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))) @@ -926,10 +950,23 @@ (send (get-dc) set-scale 1 1) (send (get-dc) set-origin 0 0) - (let ([dc (if ps? - (let ([dc (if (eq? ps? 'print) - (make-object printer-dc%) - (make-object post-script-dc%))]) + (let ([dc (if kind + (let ([dc (case kind + [(print) (make-object printer-dc%)] + [(ps pdf) + (let ([page? + (eq? 'yes (message-box + "Bounding Box" + "Use paper bounding box?" + #f + '(yes-no)))]) + (new (if (eq? kind 'ps) + post-script-dc% + pdf-dc%) + [width (* xscale DRAW-WIDTH)] + [height (* yscale DRAW-HEIGHT)] + [as-eps (not page?)] + [use-paper-bbox page?]))])]) (and (send dc ok?) dc)) (if (and use-bitmap?) (begin @@ -937,12 +974,16 @@ mem-dc) (get-dc)))]) (when dc - (send dc clear) - - (send dc start-doc "Draw Test") + (send dc start-doc "Draw Test") (send dc start-page) - (send dc set-alpha current-alpha) + (send dc clear) + + (send dc set-alpha current-alpha) + (send dc set-rotation (- current-rotation)) + (send dc set-initial-matrix (if current-skew? + (vector 1 0 0.2 1 3 0) + (vector 1 0 0 1 0 0))) (if clip-pre-scale? (begin @@ -988,7 +1029,7 @@ (send dc set-clipping-region r))] [(rect+poly) (let ([r (mk-poly 'winding)]) (send r union (mk-rect)) - (send dc set-clipping-region r))] + (send dc set-clipping-region r))] [(rect+circle) (let ([r (mk-circle)]) (send r union (mk-rect)) (send dc set-clipping-region r))] @@ -1054,9 +1095,9 @@ (unless clock-clip? (let ([r (send dc get-clipping-region)]) - (if (eq? clip 'none) + (if (eq? clip 'none) (when r - (error 'draw-test "shouldn't have been a clipping region")) + (show-error 'draw-test "shouldn't have been a clipping region")) (let*-values ([(x y w h) (send r get-bounding-box)] [(l) (list x y w h)] [(=~) (lambda (x y) @@ -1080,15 +1121,18 @@ (- (/ (caddr l) xscale) offset) (- (/ (cadddr l) yscale) offset)) l))) - (error 'draw-test "clipping region changed badly: ~a" l)))))) + (show-error 'draw-test "clipping region changed badly: ~a" l)))))) (let-values ([(w h) (send dc get-size)]) (unless (cond - [ps? #t] + [kind #t] [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) - (error 'x "wrong size reported by get-size: ~a ~a" w h))) + (show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h + (if use-bitmap? + (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) + (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) (send dc set-clipping-region #f) @@ -1112,10 +1156,10 @@ '(horizontal)) (make-object button% "PS" hp (lambda (self event) - (send canvas on-paint #t))) - (make-object button% "Print" hp + (send canvas on-paint 'ps))) + (make-object button% "PDF" hp (lambda (self event) - (send canvas on-paint 'print))) + (send canvas on-paint 'pdf))) (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp (lambda (self event) (send canvas set-scale @@ -1212,13 +1256,28 @@ (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) + (make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print))) + (make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)]) + (when c + (send (current-ps-setup) copy-from c))))) (make-object slider% "Alpha" 0 10 hp4 (lambda (s e) (let ([a (/ (send s get-value) 10.0)]) (unless (= a current-alpha) (set! current-alpha a) (send canvas refresh)))) - 10 '(horizontal plain)))) + 10 '(horizontal plain)) + (make-object slider% "Rotation" 0 100 hp4 + (lambda (s e) + (let ([a (* pi 1/4 (/ (send s get-value) 100.0))]) + (unless (= a current-rotation) + (set! current-rotation a) + (send canvas refresh)))) + 0 '(horizontal plain)) + (make-object check-box% "Skew" hp4 + (lambda (c e) + (set! current-skew? (send c get-value)) + (send canvas refresh))))) (send f show #t)) diff --git a/collects/tests/gracket/editor.rktl b/collects/tests/gracket/editor.rktl index a40b8ba9..7551cca2 100644 --- a/collects/tests/gracket/editor.rktl +++ b/collects/tests/gracket/editor.rktl @@ -259,7 +259,32 @@ (test 'hello 'read (read p)) (test 'there 'read (read p)) (test 'res 'read (read p)) - (test #t 'read (is-a? (read p) image-snip%)))) + (test #t 'read (is-a? (read p) image-snip%))) + + + (let () + (define t (new text%)) + (send t insert (make-string 5000 #\a)) + (define p (open-input-text-editor t #:lock-while-reading? #t)) + (define locked-first (send t is-locked?)) + (void (read p)) ;; read the (big) symbol + (void (read p)) ;; read eof + (define locked-last (send t is-locked?)) + (test #t 'lock-while-reading?1 (and locked-first (not locked-last)))) + + (let () + (define t (new text%)) + (send t insert (make-string 5000 #\a)) + (send t insert (make-object image-snip%)) + (define p (open-input-text-editor t #:lock-while-reading? #t)) + (define locked-first (send t is-locked?)) + (void (read p)) ;; read the (big) symbol + (void (read p)) ;; read the image + (void (read p)) ;; read eof + (define locked-last (send t is-locked?)) + (test #t 'lock-while-reading?2 + (and locked-first + (not locked-last))))) (let () (define x (new text%)) diff --git a/collects/tests/gracket/flush-stress.rkt b/collects/tests/gracket/flush-stress.rkt new file mode 100644 index 00000000..cddbaff6 --- /dev/null +++ b/collects/tests/gracket/flush-stress.rkt @@ -0,0 +1,50 @@ +#lang racket/gui + +(define SIZE 600) + +(define f (new frame% + [label "Color Bars"] + [width SIZE] + [height SIZE])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +;; If sync is turned off, then expect the drawing +;; to flicker horribly: +(define sync? #t) + +;; If flush-on-sync is disabled, the expect refresh +;; to starve, so that the image moves very rarely, if +;; at all: +(define flush-on-sync? #t) + +(define (start-drawing dc) + (when sync? + (send dc suspend-flush))) + +(define (end-drawing dc) + (when sync? + (send dc resume-flush) + (when flush-on-sync? + (send dc flush)))) + +(define (go) + (let ([dc (send c get-dc)]) + (for ([d (in-naturals)]) + (start-drawing dc) + (send dc erase) + ;; Draw somthing slow that changes with d + (for ([n (in-range 0 SIZE)]) + (send dc set-pen + (make-object color% + (remainder (+ n d) 256) + (remainder (* 2 (+ n d)) 256) + (remainder (* 3 (+ n d)) 256)) + 1 + 'solid) + (send dc draw-line n 0 n SIZE)) + (end-drawing dc)))) + +(thread go) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index f9ff3383..493bfedc 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1,4 +1,3 @@ - #lang scheme/gui (require mzlib/class @@ -51,6 +50,10 @@ 20 'decorative 'normal 'bold #f)) +(define italic-font (send the-font-list find-or-create-font + 13 'roman + 'italic 'normal + #f)) (define ($ font) (or font normal-control-font)) (define (make-h&s cp f) @@ -133,7 +136,7 @@ (if (not l) win l)))]) - (when noisy? (printf "~a~n" s)) + (when noisy? (printf "~a\n" s)) (send m set-label (substring s 0 (min 200 (string-length s)))))))) (define (add-click-intercept frame panel) @@ -146,7 +149,7 @@ (make-object menu-item% (format "Click on ~a" win) m (lambda (i e) (unless (eq? (send m get-popup-target) win) - (printf "Wrong owner!~n")))) + (printf "Wrong owner!\n")))) (send win popup-menu m (inexact->exact (send e get-x)) (inexact->exact (send e get-y))) @@ -160,7 +163,7 @@ [cc (make-object cursor% 'cross)]) (make-object check-box% "Control Bullseye Cursors" panel (lambda (c e) - (printf "~a~n" e) + (printf "~a\n" e) (if (send c get-value) (set! old (map (lambda (b) @@ -200,7 +203,7 @@ (override [on-demand (lambda () - (printf "Menu item ~a demanded~n" name))]) + (printf "Menu item ~a demanded\n" name))]) (sequence (apply super-init name args)))) @@ -239,7 +242,7 @@ (memq (send e get-event-type) '(menu-popdown menu-popdown-none))) (error "bad event object")) - (printf "popdown ok~n")))] + (printf "popdown ok\n")))] [make-callback (let ([id 0]) (lambda () @@ -297,7 +300,7 @@ (sequence (apply super-init args) (unless (ok?) - (printf "bitmap failure: ~s~n" args))))) + (printf "bitmap failure: ~s\n" args))))) (define (active-mixin %) (class % @@ -312,9 +315,9 @@ [on-subwindow-char (lambda args (or (apply pre-on args) (super on-subwindow-char . args)))] - [on-activate (lambda (on?) (printf "active: ~a~n" on?))] - [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))] - [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))]) + [on-activate (lambda (on?) (printf "active: ~a\n" on?))] + [on-move (lambda (x y) (printf "moved: ~a ~a\n" x y))] + [on-size (lambda (x y) (printf "sized: ~a ~a\n" x y))]) (public* [set-info (lambda (ep) (set! pre-on (add-pre-note this ep)) @@ -331,10 +334,10 @@ (override [on-superwindow-show (lambda (on?) - (printf "~a ~a~n" name (if on? "show" "hide")))] + (printf "~a ~a\n" name (if on? "show" "hide")))] [on-superwindow-enable (lambda (on?) - (printf "~a ~a~n" name (if on? "on" "off")))]) + (printf "~a ~a\n" name (if on? "on" "off")))]) (sequence (apply super-init name args)))) @@ -952,7 +955,7 @@ (compare expect v (format "label search: ~a" string))))] [tell-ok (lambda () - (printf "ok~n"))]) + (printf "ok\n"))]) (private-field [temp-labels? #f] [use-menubar? #f] @@ -1180,7 +1183,7 @@ (unless (memq type types) (error (format "bad event type: ~a" type)))) (unless silent? - (printf "Callback Ok~n"))) + (printf "Callback Ok\n"))) (define (instructions v-panel file) (define c (make-object editor-canvas% v-panel)) @@ -1216,7 +1219,7 @@ (lambda (e) (check-callback-event b b e commands #t)) old-list) - (printf "All Ok~n")))) + (printf "All Ok\n")))) (define e (make-object button% "Disable Test" p (lambda (c e) @@ -1227,7 +1230,7 @@ (thread (lambda () (sleep 0.5) (semaphore-post sema))) (yield sema) (when hit? - (printf "un-oh~n")) + (printf "un-oh\n")) (send b enable #t))))) (instructions p "button-steps.txt") (send f show #t)) @@ -1261,7 +1264,7 @@ (lambda (e) (check-callback-event cb cb e commands #t)) old-list) - (printf "All Ok~n")))) + (printf "All Ok\n")))) (instructions p "checkbox-steps.txt") (send f show #t)) @@ -1333,7 +1336,7 @@ (lambda (rbe) (check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t)) old-list) - (printf "All Ok~n"))) + (printf "All Ok\n"))) (instructions p "radiobox-steps.txt") (send f show #t)) @@ -1360,12 +1363,12 @@ (cond [(eq? (send e get-event-type) 'list-box-dclick) ; double-click - (printf "Double-click~n") + (printf "Double-click\n") (unless (send cx get-selection) (error "no selection for dclick"))] [else ; misc multi-selection - (printf "Changed: ~a~n" (if list? + (printf "Changed: ~a\n" (if list? (send cx get-selections) (send cx get-selection)))]) (check-callback-event c cx e commands #f))) @@ -1402,7 +1405,7 @@ (make-object button% "Visible Indices" p (lambda (b e) - (printf "top: ~a~nvisible count: ~a~n" + (printf "top: ~a\nvisible count: ~a\n" (send c get-first-visible-item) (send c number-of-visible-items)))))) (define cdp (make-object horizontal-panel% p)) @@ -1555,14 +1558,87 @@ (lambda (e) (check-callback-event c c e commands #t)) old-list) - (printf "content: ~s~n" actual-content) + (printf "content: ~s\n" actual-content) (when multi? - (printf "selections: ~s~n" (send c get-selections)))))) + (printf "selections: ~s\n" (send c get-selections)))))) (send c stretchable-width #t) (instructions p "choice-list-steps.txt") (send f show #t)) -(define (slider-frame) +(define (combo-frame empty?) + (define f (make-frame frame% "Combo Test")) + (define p f) + (define actual-content '("Apple" "Banana")) + (define (callback c e) (void)) + (define c (make-object (class combo-field% + (define/override (on-popup e) + (printf "Popup!\n")) + (super-new)) + "Tester" actual-content p callback)) + (define counter 0) + (define append-with-user-data? #f) + (define ab (make-object button% + "Append" p + (lambda (b e) + (set! counter (add1 counter)) + (let ([naya (format "~aExtra ~a" + (if (= counter 10) + (string-append + "This is a Really Long Named Item That Would Have Used the Short Name, Yes " + "This is a Really Long Named Item That Would Have Used the Short Name ") + "") + counter)] + [naya-data (box 0)]) + (set! actual-content (append actual-content (list naya))) + (send c append naya))))) + (define asb (make-object button% + "Append Separator" p + (lambda (b e) + (set! counter (add1 counter)) + (new separator-menu-item% [parent (send c get-menu)])))) + (define cdp (make-object horizontal-panel% p)) + (define (clear) + (for ([i (send (send c get-menu) get-items)]) + (send i delete))) + (define rb (make-object button% "Clear" cdp + (lambda (b e) (clear)))) + (define (gone l n) + (if (zero? n) + (cdr l) + (cons (car l) (gone (cdr l) (sub1 n))))) + (define (delete p) + (send (list-ref (send (send c get-menu) get-items) p) delete) + (when (<= 0 p (sub1 (length actual-content))) + (set! actual-content (gone actual-content p)))) + (define db (make-object button% + "Delete First" cdp + (lambda (b e) + (unless (null? actual-content) + (delete 0))))) + (define dbe (make-object button% + "Delete Last" cdp + (lambda (b e) + (unless (null? actual-content) + (delete (sub1 (length actual-content))))))) + (define setb (make-object button% + "Reset" cdp + (lambda (b e) + (clear) + (let ([m (send c get-menu)]) + (for ([i '("Alpha" "Beta" "Gamma")]) + (new menu-item% [parent m] [label i] + [callback (lambda (itm e) + (send c set-value + (format "~a from Reset" i)))])))))) + (define tb (make-object button% + "Check" p + (lambda (b e) + (void)))) + (send c stretchable-width #t) + (instructions p "combo-steps.txt") + (send f show #t)) + +(define (slider-frame style) (define f (make-frame frame% "Slider Test")) (define p (make-object vertical-panel% f)) (define old-list null) @@ -1570,15 +1646,16 @@ (define s (make-object slider% "Slide Me" -1 11 p (lambda (sl e) (check-callback-event s sl e commands #f) - (printf "slid: ~a~n" (send s get-value))) - 3)) + (printf "slid: ~a\n" (send s get-value))) + 3 + (cons 'horizontal style))) (define c (make-object button% "Check" p (lambda (c e) (for-each (lambda (e) (check-callback-event s s e commands #t)) old-list) - (printf "All Ok~n")))) + (printf "All Ok\n")))) (define (simulate v) (let ([e (make-object control-event% 'slider)]) (send s set-value v) @@ -1634,13 +1711,13 @@ (define (handler get-this) (lambda (c e) (unless (eq? c (get-this)) - (printf "callback: bad item: ~a~n" c)) + (printf "callback: bad item: ~a\n" c)) (let ([t (send e get-event-type)]) (cond [(eq? t 'text-field) - (printf "Changed: ~a~n" (send c get-value))] + (printf "Changed: ~a\n" (send c get-value))] [(eq? t 'text-field-enter) - (printf "Return: ~a~n" (send c get-value))])))) + (printf "Return: ~a\n" (send c get-value))])))) (define f (make-frame frame% "Text Test")) (define p (make-object vertical-panel% f)) @@ -1679,7 +1756,7 @@ (get-scroll-pos 'horizontal) (get-scroll-range 'horizontal) (get-scroll-page 'horizontal))] - [dc (get-dc)]) + [dc (get-dc)]) (let-values ([(w h) (get-client-size)] [(w2 h2) (get-virtual-size)] [(x y) (get-view-start)]) @@ -1701,7 +1778,7 @@ (send f set-status-text s)))] [on-scroll (lambda (e) - (when auto? (printf "Hey - on-scroll called for auto scrollbars~n")) + (when auto? (printf "Hey - on-scroll called for auto scrollbars\n")) (unless incremental? (on-paint)))] [init-auto-scrollbars (lambda x (set! auto? #t) @@ -1877,7 +1954,7 @@ (let ([c (car (send p get-children))]) (let-values ([(w h) (send c get-size)] [(cw ch) (send c get-client-size)]) - (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}~n" + (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}\n" c w h cw ch (- w cw) (- h ch) (send c min-width) (send c min-height))))) @@ -1962,7 +2039,7 @@ (make-object button% "Rename" p2 (lambda (b e) (send p set-item-label (quotient (send p get-number) 2) "Do&nut"))) (make-object button% "Labels" p2 (lambda (b e) - (printf "~s~n" + (printf "~s\n" (reverse (let loop ([i (send p get-number)]) (if (zero? i) @@ -2000,10 +2077,10 @@ (define (message-boxes parent) (define (check expected got) (unless (eq? expected got) - (fprintf (current-error-port) "bad result: - expected ~e, got ~e~n" + (fprintf (current-error-port) "bad result: - expected ~e, got ~e\n" expected got))) (define (big s) - (format "~a~n~a~n~a~n~a~n" s + (format "~a\n~a\n~a\n~a\n" s (make-string 500 #\x) (make-string 500 #\x) (make-string 500 #\x))) @@ -2070,7 +2147,7 @@ f (lambda (b e) (send f set-cursor (make-object cursor% s))))) - '(arrow bullseye cross hand ibeam watch arrow-watch blank size-n/s size-e/w size-ne/sw size-nw/se)) + '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se)) (send f show #t)) @@ -2159,6 +2236,7 @@ (send cp stretchable-width #f) (make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f))) (make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t))) +(make-object button% "Make Combo Frame" cp (lambda (b e) (combo-frame #f))) (define lp (make-object horizontal-pane% ap)) (send lp stretchable-width #f) (make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f))) @@ -2169,17 +2247,18 @@ (send gsp stretchable-height #f) (make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame))) (make-object vertical-pane% gsp) ; filler -(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame))) +(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame null))) +(make-object button% "Make Plain Slider Frame" gsp (lambda (b e) (slider-frame '(plain)))) (make-object vertical-pane% gsp) ; filler (make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f))) (make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t))) -(make-object vertical-pane% gsp) ; filler -(make-object button% "Make Modified Frame" gsp (lambda (b e) (test-modified-frame))) (define tp (make-object horizontal-pane% ap)) (send tp stretchable-width #f) (make-object button% "Make Text Frame" tp (lambda (b e) (text-frame '(single)))) (make-object button% "Make Multitext Frame" tp (lambda (b e) (text-frame '(multiple)))) +(make-object vertical-pane% tp) ; filler +(make-object button% "Make Modified Frame" tp (lambda (b e) (test-modified-frame))) (define cnp (make-object horizontal-pane% ap)) (send cnp stretchable-width #t) @@ -2214,7 +2293,7 @@ (let loop ([l radios]) (let* ([c (car l)] [rest (cdr l)] - [n (send c number)] + [n (send c get-number)] [v (send c get-selection)]) (if (< v (sub1 n)) (send c set-selection (add1 v)) @@ -2252,7 +2331,7 @@ (make-radio-box "Stretchiness" '("Normal" "All Stretchy") p1 void)) (define font-radio - (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big") + (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big" "Italic") p1 void)) (define enabled-radio (make-radio-box "Initially" '("Enabled" "Disabled") @@ -2275,7 +2354,8 @@ (list-ref (list #f small-control-font tiny-control-font - special-font) + special-font + italic-font) (send font-radio get-selection)) (positive? (send enabled-radio get-selection)) (positive? (send selection-radio get-selection)) diff --git a/collects/tests/gracket/mem.rktl b/collects/tests/gracket/mem.rkt similarity index 93% rename from collects/tests/gracket/mem.rktl rename to collects/tests/gracket/mem.rkt index 78ea4c90..ae8d663e 100644 --- a/collects/tests/gracket/mem.rktl +++ b/collects/tests/gracket/mem.rkt @@ -1,11 +1,10 @@ - -; run with gracket -u -- -f mem.rktl +#lang racket/gui (require mzlib/class100) (define source-dir (current-load-relative-directory)) -(define num-times 8) +(define num-times 80) (define num-threads 3) (define dump-stats? #f) @@ -28,13 +27,12 @@ allocated)) v) -(when subwindows? - (namespace-set-variable-value! - 'sub-collect-frame - (make-object frame% "sub-collect")) - (namespace-set-variable-value! - 'sub-collect-panel - (make-object panel% sub-collect-frame))) +(define sub-collect-frame + (and subwindows? + (make-object frame% "sub-collect"))) +(define sub-collect-panel + (and subwindows? + (make-object panel% sub-collect-frame))) (define permanent-ready? #f) (define mb-lock (make-semaphore 1)) @@ -68,7 +66,7 @@ (sleep) (collect-garbage) (collect-garbage) - (printf "Thread: ~s Cycle: ~s~n" id n) + (printf "Thread: ~s Cycle: ~s\n" id n) ; (dump-object-stats) ; (if (and dump-stats? (= id 1)) ; (dump-memory-stats)) @@ -154,6 +152,7 @@ (when (and edit? insert?) (let ([e edit]) + (send e begin-edit-sequence) (when load-file? (send e load-file (build-path source-dir "mem.ss"))) (let loop ([i 20]) @@ -165,7 +164,8 @@ (send e insert s)) (send e insert #\newline) (send e insert "done") - (send e set-modified #f))) + (send e set-modified #f) + (send e end-edit-sequence))) (when menus? (let ([f (remember tag (make-object frame% "MB Frame 0"))]) @@ -229,7 +229,7 @@ (map (lambda (x) (let ([v (weak-box-value (cdr x))]) (when v - (printf "~s ~s~n" (car x) v)))) + (printf "~s ~s\n" (car x) v)))) allocated) (void)) @@ -243,10 +243,10 @@ (if #f (thread (lambda () (read) - (printf "breaking~n") + (printf "breaking\n") (break-thread t) (thread-wait t) - (printf "done~n"))) + (printf "done\n"))) (void))) (define (do-test) diff --git a/collects/tests/gracket/paramz.rktl b/collects/tests/gracket/paramz.rktl index 02f362f3..36e7697a 100644 --- a/collects/tests/gracket/paramz.rktl +++ b/collects/tests/gracket/paramz.rktl @@ -34,7 +34,7 @@ (define d (make-object dialog% "hello")) (thread (lambda () - (sleep 1) + (sync (system-idle-evt)) (queue-callback (lambda () (set! v 11))) (send d show #f))) (queue-callback (lambda () (set! v 10))) @@ -56,15 +56,17 @@ (st #f d is-shown?) (let ([t (thread (lambda () - (send d show #t)))]) - (let loop () (unless (send d is-shown?) (loop))) + (send d show #t)))]) + (let loop () (unless (send d is-shown?) (sleep) (loop))) (st #t d is-shown?) (thread-suspend t) (stv d show #f) + (st #f d is-shown?) (let ([t2 (thread (lambda () (send d show #t)))]) - (sleep 0.1) + (yield (system-idle-evt)) + (st #t d is-shown?) (thread-resume t) - (sleep 0.1) + (yield (system-idle-evt)) (st #t d is-shown?) (test #t 'thread2 (thread-running? t2)) (stv d show #f) @@ -93,7 +95,7 @@ (and (exn:fail? x) (regexp-match "shutdown" (exn-message x)))) (lambda (x) - (printf "got expected error: ~a~n" (exn-message x)) + (printf "got expected error: ~a\n" (exn-message x)) 'error)]) (parameterize ([current-eventspace e]) (t))))) diff --git a/collects/tests/gracket/showkey.rkt b/collects/tests/gracket/showkey.rkt new file mode 100644 index 00000000..9f7705ec --- /dev/null +++ b/collects/tests/gracket/showkey.rkt @@ -0,0 +1,84 @@ +#lang racket/base +(require racket/gui/base + racket/class + racket/cmdline) + +(command-line + #:once-each + [("--option") "set special Option key" + (special-option-key #t)] + [("--control") "set special Control key" + (special-control-key #t)]) + +(let () + (define iter 0) + (define c% + (class canvas% + (super-new) + (define/override (on-event ev) + (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" + (es-check) + iter + (send ev get-event-type) + (send ev get-x) + (send ev get-y) + (if (send ev get-meta-down) " META" "") + (if (send ev get-control-down) " CTL" "") + (if (send ev get-alt-down) " ALT" "") + (if (send ev get-shift-down) " SHIFT" "") + (if (send ev get-caps-down) " CAPS" "") + (if (send ev get-left-down) " LEFT" "") + (if (send ev get-middle-down) " MIDDLE" "") + (if (send ev get-right-down) " RIGHT" "") + (if (send ev dragging?) + " dragging" + "") + (if (send ev moving?) + " moving" + "") + (if (send ev entering?) + " entering" + "") + (if (send ev leaving?) + " leaving" + ""))) + (define/override (on-char ev) + (set! iter (add1 iter)) + (printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a\n" + (es-check) + iter + (let ([v (send ev get-key-code)]) + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v)))) + (let ([v (send ev get-key-release-code)]) + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v)))) + (let ([vs (list (send ev get-other-shift-key-code) + (send ev get-other-altgr-key-code) + (send ev get-other-shift-altgr-key-code) + (send ev get-other-caps-key-code))]) + (map (lambda (v) + (and v + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v))))) + vs)) + (if (send ev get-meta-down) " META" "") + (if (send ev get-control-down) " CTL" "") + (if (send ev get-alt-down) " ALT" "") + (if (send ev get-shift-down) " SHIFT" "") + (if (send ev get-caps-down) " CAPS" ""))))) + (define f (make-object (class frame% + (inherit accept-drop-files) + (define/override (on-drop-file file) + (printf "Dropped: ~a\n" file)) + (super-make-object "tests" #f 100 100) + (accept-drop-files #t)))) + (define c (make-object c% f)) + (define (es-check) (if (eq? (send f get-eventspace) (current-eventspace)) + "" + ">>WRONG EVENTSPACE<<\n")) + (send c focus) + (send f show #t)) diff --git a/collects/tests/gracket/testing.rktl b/collects/tests/gracket/testing.rktl index 0e3c9880..573a5e1c 100644 --- a/collects/tests/gracket/testing.rktl +++ b/collects/tests/gracket/testing.rktl @@ -12,7 +12,7 @@ (set! test-count (add1 test-count)) (unless (equal? expect got) (let ([s (format "~a: expected ~e; got ~e" name expect got)]) - (fprintf (current-error-port) "ERROR: ~a~n" s) + (fprintf (current-error-port) "ERROR: ~a\n" s) (set! errs (cons s errs))))) (define-syntax mismatch @@ -23,7 +23,7 @@ (test 'was-mismatch 'mismtach (with-handlers ([exn:fail:contract? (lambda (x) - (printf "~a~n" (exn-message x)) + (printf "~a\n" (exn-message x)) 'was-mismatch)] [exn:fail? values]) expr)))]))) @@ -51,11 +51,11 @@ (define (report-errs) (newline) (if (null? errs) - (printf "Passed all ~a tests~n" test-count) + (printf "Passed all ~a tests\n" test-count) (begin - (fprintf (current-error-port) "~a Error(s) in ~a tests~n" (length errs) test-count) + (fprintf (current-error-port) "~a Error(s) in ~a tests\n" (length errs) test-count) (for-each (lambda (s) - (fprintf (current-error-port) "~a~n" s)) + (fprintf (current-error-port) "~a\n" s)) (reverse errs))))) diff --git a/collects/tests/gracket/unflushed-circle.rkt b/collects/tests/gracket/unflushed-circle.rkt new file mode 100644 index 00000000..7376ed62 --- /dev/null +++ b/collects/tests/gracket/unflushed-circle.rkt @@ -0,0 +1,43 @@ +#lang racket/gui +(require racket/math) + +;; This test creates a background that draws a circle in changing +;; colors. It draws in a background thread --- on in response to +;; `on-paint', and with no flushing controls --- but it should nevertheless +;; refresh onscreen frequently through an automatic flush. + +(define f (new frame% + [label "Snake"] + [width 400] + [height 400])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +(define prev-count 0) +(define next-time (+ (current-inexact-milliseconds) 1000)) + +(define (go) + (let loop ([n 0]) + (when ((current-inexact-milliseconds) . > . next-time) + (printf "~s\n" (- n prev-count)) + (set! prev-count n) + (set! next-time (+ (current-inexact-milliseconds) 1000))) + (let ([p (make-polar 175 (* pi (/ n 100)))] + [dc (send c get-dc)]) + (send dc set-brush + (make-object color% + (remainder n 256) + (remainder (* 2 n) 256) + (remainder (* 3 n) 256)) + 'solid) + (send dc draw-rectangle + (+ 180 (real-part p)) + (+ 180 (imag-part p)) + 20 + 20) + (loop (add1 n))))) + +(thread go) + diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 3c952a89..1f36d1d9 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -30,6 +30,17 @@ (thread (lambda () (sleep 0.01) (semaphore-post s))) (test s 'yield (yield s)))) +(define (iconize-pause) + (if (eq? 'unix (system-type)) + ;; iconization might take a while + ;; for the window manager to report back + (begin + (pause) + (when (regexp-match? #rx"darwin" (path->string (system-library-subpath))) + (sleep 0.75)) + (pause)) + (pause))) + (let ([s (make-semaphore 1)]) (test s 'yield-wrapped (yield s))) (let ([s (make-semaphore 1)]) @@ -39,7 +50,7 @@ (test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v)))))) (define (enable-tests f) - (printf "Enable ~a~n" f) + (printf "Enable ~a\n" f) (st #t f is-enabled?) (stv f enable #f) (st #f f is-enabled?) @@ -47,7 +58,7 @@ (st #t f is-enabled?)) (define (drop-file-tests f) - (printf "Drop File ~a~n" f) + (printf "Drop File ~a\n" f) (st #f f accept-drop-files) (stv f accept-drop-files #t) (st #t f accept-drop-files) @@ -55,7 +66,8 @@ (st #f f accept-drop-files)) (define (client->screen-tests f) - (printf "Client<->Screen ~a~n" f) + (printf "Client<->Screen ~a\n" f) + (send (or (send f get-parent) f) reflow-container) (let-values ([(x y) (send f client->screen 0 0)]) (stvals '(0 0) f screen->client x y)) (let-values ([(x y) (send f screen->client 0 0)]) @@ -65,8 +77,8 @@ (test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h)))) (stv f refresh)) -(define (area-tests f sw? sh? no-stretch?) - (printf "Area ~a~n" f) +(define (area-tests f sw? sh? no-stretch? use-client-size?) + (printf "Area ~a\n" f) (let ([x (send f min-width)] [y (send f min-height)]) (st sw? f stretchable-width) @@ -74,9 +86,11 @@ (stv (send f get-top-level-window) reflow-container) (pause) ; to make sure size has taken effect (let-values ([(w h) (if no-stretch? - (send f get-size) + (if use-client-size? + (send f get-client-size) + (send f get-size)) (values 0 0))]) - (printf "Size ~a x ~a~n" w h) + (printf "Size ~a x ~a\n" w h) (when no-stretch? (stv f min-width w) ; when we turn of stretchability, don't resize (stv f min-height h)) @@ -94,8 +108,8 @@ (stv f min-height y))) (define (containee-tests f sw? sh? m) - (area-tests f sw? sh? #f) - (printf "Containee ~a~n" f) + (area-tests f sw? sh? #f #f) + (printf "Containee ~a\n" f) (st m f horiz-margin) (st m f vert-margin) (stv f horiz-margin 3) @@ -108,14 +122,14 @@ (stv f vert-margin m)) (define (container-tests f win?) - (printf "Container ~a~n" f) + (printf "Container ~a\n" f) (let-values ([(x y) (send f get-alignment)]) (stv f set-alignment 'right 'bottom) (stvals '(right bottom) f get-alignment) (stv f set-alignment x y))) (define (cursor-tests f) - (printf "Cursor ~a~n" f) + (printf "Cursor ~a\n" f) (let ([c (send f get-cursor)]) (stv f set-cursor c) (st c f get-cursor) @@ -131,7 +145,7 @@ (define (show-tests f) (unless (is-a? f dialog%) - (printf "Show ~a~n" f) + (printf "Show ~a\n" f) (let ([on? (send f is-shown?)]) (stv f show #f) (when on? @@ -165,7 +179,7 @@ (st my-l b get-plain-label) (stv b set-label &-l))) -(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)]) +(let ([f (make-object frame% "Yes & No" #f 150 151 70 21)]) (let ([init-tests (lambda (hidden?) (st "Yes & No" f get-label) @@ -176,15 +190,8 @@ (stv f set-label "Yes & No") (st #f f get-parent) (st f f get-top-level-window) - (case (system-type 'os) - [(unix) - (st 21 f get-x) - (if hidden? - (st 43 f get-y) - (st 22 f get-y))] - [else - (st 20 f get-x) - (st 21 f get-y)]) + (st 70 f get-x) + (st 21 f get-y) (st 150 f get-width) (st 151 f get-height) (stvals (list (send f get-width) (send f get-height)) f get-size) @@ -193,7 +200,7 @@ (st #f f get-menu-bar))] [space-tests (lambda () - (printf "Spacing~n") + (printf "Spacing\n") (let ([b (send f border)]) (stv f border 25) (st 25 f border) @@ -209,15 +216,15 @@ (drop-file-tests f))] [client->screen-tests (lambda () - (printf "Client<->Screen~n") + (printf "Client<->Screen\n") (let-values ([(x y) (send f client->screen 0 0)]) (stvals '(0 0) f screen->client x y)) (let-values ([(x y) (send f screen->client 0 0)]) (stvals '(0 0) f client->screen x y)))] [container-tests (lambda () - (printf "Container~n") - (area-tests f #t #t #t) + (printf "Container\n") + (area-tests f #t #t #t #t) (let-values ([(x y) (send f container-size null)]) (st x f min-width) (st y f min-height)) @@ -238,15 +245,15 @@ (container-tests) (cursor-tests) - (printf "Init~n") + (printf "Init\n") (init-tests #f) (stv f show #t) (pause) - (printf "Show Init~n") + (printf "Show Init\n") (init-tests #t) (stv f show #f) (pause) - (printf "Hide Init~n") + (printf "Hide Init\n") (init-tests #f) (send f show #t) (pause) @@ -258,21 +265,26 @@ (stv f change-children values) - (printf "Iconize~n") + (printf "Iconize\n") (stv f iconize #t) - (pause) - (pause) - (st #t f is-iconized?) ; NB: test will fail on MacOS - (stv f show #t) - (pause) + (iconize-pause) + (st #t f is-iconized?) + (stv f iconize #f) + (iconize-pause) (st #f f is-iconized?) - + (stv f iconize #t) + (iconize-pause) + (st #t f is-iconized?) + (stv f show #t) + (iconize-pause) + (st #f f is-iconized?) + (stv f maximize #t) (pause) (stv f maximize #f) (pause) - (printf "Move~n") + (printf "Move\n") (stv f move 34 37) (pause) (FAILS (st 34 f get-x)) @@ -280,17 +292,17 @@ (st 150 f get-width) (st 151 f get-height) - (printf "Resize~n") - (stv f resize 56 57) + (printf "Resize\n") + (stv f resize 156 57) (pause) (FAILS (st 34 f get-x)) (FAILS (st 37 f get-y)) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (stv f center) (pause) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (client->screen-tests) @@ -306,7 +318,7 @@ (cursor-tests) - (printf "Menu Bar~n") + (printf "Menu Bar\n") (let ([mb (make-object menu-bar% f)]) (st mb f get-menu-bar) (st f mb get-frame) @@ -320,11 +332,11 @@ (st null mb get-items) - (printf "Menu 1~n") + (printf "Menu 1\n") (let* ([m (make-object menu% "&File" mb)] [i m] [delete-enable-test (lambda (i parent empty) - (printf "Item~n") + (printf "Item\n") (st #f i is-deleted?) (st #t i is-enabled?) @@ -371,7 +383,7 @@ (st null m get-items) - (printf "Menu Items~n") + (printf "Menu Items\n") (let ([i1 (make-object menu-item% "&Plain" m (lambda (i e) (test-control-event e '(menu)) @@ -391,7 +403,7 @@ (lambda (i empty name) (delete-enable-test i m empty) - (printf "Shortcut~n") + (printf "Shortcut\n") (set! hit i) (stv i command (make-object control-event% 'menu)) (test name 'hit-command hit) @@ -437,7 +449,7 @@ 'done) - (printf "Menu 2~n") + (printf "Menu 2\n") (let* ([m2 (make-object menu% "&Edit" mb "Help Edit")] [i2 m2]) (st (list i i2) mb get-items) @@ -468,7 +480,7 @@ (define (test-controls parent frame) (define side-effect #f) - (printf "Buttons~n") + (printf "Buttons\n") (letrec ([b (make-object button% "&Button" parent @@ -484,7 +496,7 @@ (containee-window-tests b #f #f parent frame 2)) - (printf "Check Box~n") + (printf "Check Box\n") (letrec ([c (make-object check-box% "&Check Box" parent @@ -511,7 +523,7 @@ #t)]) (st #t c get-value)) - (printf "Radio Box~n") + (printf "Radio Box\n") (letrec ([r (make-object radio-box% "&Radio Box" (list "O&ne" "T&wo" "T&hree") @@ -586,7 +598,7 @@ '(vertical) 3)) - (printf "Gauge~n") + (printf "Gauge\n") (letrec ([g (make-object gauge% "&Gauge" 10 @@ -618,7 +630,7 @@ (containee-window-tests g #t #f parent frame 2)) - (printf "Slider~n") + (printf "Slider\n") (letrec ([s (make-object slider% "&Slider" -2 8 @@ -774,7 +786,7 @@ 'done-list)]) - (printf "Choice~n") + (printf "Choice\n") (letrec ([c (make-object choice% "&Choice" '("A" "B" "C & D") @@ -808,7 +820,7 @@ (let ([mk-list (lambda (style) - (printf "List Box: ~a~n" style) + (printf "List Box: ~a\n" style) (letrec ([l (make-object list-box% "&List Box" '("A" "B" "C & D") @@ -869,7 +881,7 @@ (let ([c (make-object canvas% parent '(hscroll vscroll))]) - (printf "Tab Focus~n") + (printf "Tab Focus\n") (st #f c accept-tab-focus) (stv c accept-tab-focus #t) (st #t c accept-tab-focus) @@ -880,13 +892,13 @@ ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) (let-values ([(w h) (send c get-virtual-size)] [(cw ch) (send c get-client-size)]) - (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a~n" w h cw ch) + (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a\n" w h cw ch) (let ([check-scroll (lambda (xpos ypos) (let-values ([(x y) (send c get-view-start)]) (let ([coerce (lambda (x) (inexact->exact (floor x)))]) - (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x) - (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))]) + (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw ,w) x) + (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch , h) y))))]) (test 500 'canvas-virt-w-size w) (test 606 'canvas-virt-h-size h) @@ -958,7 +970,7 @@ 102)]) (let loop ([n 100]) (unless (zero? n) - (send e insert (format "line ~a~n" n)) + (send e insert (format "line ~a\n" n)) (loop (sub1 n)))) (st #f c allow-scroll-to-last) @@ -1009,7 +1021,7 @@ (test-controls panel frame) (if win? ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0) - (area-tests panel #t #t #f)) + (area-tests panel #t #t #f #f)) (when (is-a? panel panel%) (st #t panel get-orientation (is-a? panel horizontal-panel%))) (container-tests panel win?) diff --git a/collects/unstable/gui/notify.rkt b/collects/unstable/gui/notify.rkt index 368ea8d4..ff6f01d6 100644 --- a/collects/unstable/gui/notify.rkt +++ b/collects/unstable/gui/notify.rkt @@ -2,7 +2,7 @@ ;; owner: ryanc (require racket/list racket/class - racket/gui + racket/gui/base "../private/notify.rkt") (provide (all-from-out "../private/notify.rkt") menu-option/notify-box diff --git a/doc/release-notes/gracket/HISTORY.txt b/doc/release-notes/gracket/HISTORY.txt index ccd6fb4f..51602102 100644 --- a/doc/release-notes/gracket/HISTORY.txt +++ b/doc/release-notes/gracket/HISTORY.txt @@ -1,3 +1,9 @@ +Version 5.0.2, October 2010 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 5.0.1, July 2010 Minor bug fixes diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt new file mode 100644 index 00000000..8e3b7069 --- /dev/null +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -0,0 +1,156 @@ +GRacket, Racket, Drawing, and GUIs +---------------------------------- + +Version 5.1 includes two major changes to the Racket drawing and GUI +API: + + * The drawing portion of the GUI toolbox is now available as a + separate layer: `racket/draw'. This layer can be used independent + of the `racket/gui/base' library, although `racket/gui' re-exports + `racket/draw'. + + (The `racket/draw' library is built on top of the widely used Cairo + drawing library and Pango text-rendering library.) + + * The GRacket executable is no longer strictly necessary for running + GUI programs; the `racket/gui/base' library can be used from + Racket. + + The GRacket executable still offers some additional GUI-specific + functiontality however. Most notably, GRacket is a GUI application + under Windows (as opposed to a console application, which is + launched slightly differently by the OS), GRacket is a bundle under + Mac OS X (so the dock icon is the Racket logo, for example), and + GRacket manages single-instance mode for Windows and X. + +The drawing and GUI libraries have also changed in further small ways. + + +Bitmaps +------- + +Drawing to a bitmap may not produce the same results as drawing to a +canvas. Use the `make-screen-bitmap' function (from `racket/gui') or +the `make-bitmap' method of `canvas%' to obtain a bitmap that uses the +same drawing algorithms as a canvas. + +A color bitmap can have an alpha channel, instead of just a mask +bitmap. When drawing a bitmap, alpha channels are used more +consistently and automatically than mask bitmaps. More significantly, +drawing into a bitmap with an alpha channel preserves the drawn +alphas; for example, drawing a line in the middle of an empty bitmap +produces an image with non-zero alpha only at the drawn line. + +Only bitmaps created with the new `make-gl-bitmap' function support +OpenGL drawing. The `make-gl-bitmap' function takes a `gl-config%' as +an argument, and the `get-gl-config' and `set-gl-config' methods of +`bitmap%' have been removed. + +Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap', +`make-screen-bitmap', and `make-gl-bitmap' functions to create +bitmaps, instead of using `make-object' with `bitmap%'. The new +constructors are less overloaded and provide more modern defaults +(such as alpha channels by default). + +Image formats can be read into a `bitmap%' from from input ports, +instead of requiring a file path. A newly created bitmap has an empty +content (i.e., white with zero alpha), instead of unspecified content. + + +Canvases +-------- + +Drawing to a canvas always draws into a bitmap that is kept offscreen +and periodically flushed onto the screen. The new `suspend-flush', +`resume-flush', and `flush' methods of `canvas%' provide some control +over the timing of the flushes, which in many cases avoids the need +for (additional) double buffering of canvas content. + +OpenGL drawing in a canvas requires supplying 'gl as a style when +creating the `canvas%' instance. OpenGL and normal dc<%> drawing no +longer mix reliably in a canvas. + + +Drawing-Context Transformations +------------------------------- + +A `dc<%>' instance supports rotation (via `set-rotation'), negative +scaling factors for flipping, and a general transformation matrix (via +`set-initial-matrix'). A transformation matrix has the form `(vector +xx xy yx yy x0 y0)', where a point (x1, y1) is transformed to a point +(x2, y2) with x2 = xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0, +which is the usual convention. + +New methods `translate', `scale', `rotate', and `transform' simplify +adding a further translation, scaling, rotation, or arbitrary matrix +transformation on top of the current transformation. The new +`get-translation' and `set-translation' methods help to capture and +restore transformation settings. + +The old translation and scaling transformations apply after the +initial matrix. The new rotation transformation applies after the +other transformations. This layering is redundant, since all +transformations can be expressed in a single matrix, but it is +backward-compatibile. Methods like `get-translation', +`set-translation', `scale', etc. help hide the reundancy. + + +PostScript and PDF Drawing Contexts +----------------------------------- + +The dimensions for PostScript output are no longer inferred from the +drawing. Instead, the width and height must be supplied when the +`post-script-dc%' is created. + +The new `pdf-dc%' drawing context is like `post-script-dc%', but it +generates PDF output. + + +Other Drawing-Context Changes +----------------------------- + +The alpha value of a `dc<%>' (as set by `set-alpha') is used for all +drawing operations, including drawing a bitmap. + +The `draw-bitmap' and `draw-bitmap-section' methods now smooth bitmaps +while scaling, so the `draw-bitmap-section-smooth' method of +`bitmap-dc%' simply calls `draw-bitmap-section'. + +A `region%' can be created as independent of any `dc<%>', in which +cases it uses the drawing context's current transformation at the time +that it is installed as a clipping region. + +The old 'xor mode for pens and brushes is no longer available (since +it is not supported by Cairo). + + +Editor Changes +-------------- + +The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or +`refresh' method can be a pair, which indicates that the caret is +owned by an enclosing display and the selection spans the snip or +editor. In that case, the snip or editor should refrain from drawing a +background for the selected region, and it should draw the foreground +in the color specified by `get-highlight-text-color', if any. + + +Other GUI Changes +----------------- + +The `on-popup' method of `combo-field%' can be used to adjust the +content of the combo-box popup menu, but the default implementation no +longer triggers the popup menu; instead, the popup behavior is built +into the control. + + +Removed Functions +----------------- + +The `write-resource, `get-reource', and `send-event' functions have +been removed from `racket/gui/base'. If there is any demand for the +removed functionality, it will be implemented in a new library. + +The `current-ps-afm-file-paths' and `current-ps-cmap-file-paths' +functions have been removed, because they no longer apply. PostScript +font information is obtained through Pango. diff --git a/man/man1/gracket.1 b/man/man1/gracket.1 index e638647b..d07e1a8b 100644 --- a/man/man1/gracket.1 +++ b/man/man1/gracket.1 @@ -48,7 +48,7 @@ Alternately, consult the on-line documentation and other information available at .PP .ce 1 -http://www.racket-lang.org/ +http://racket-lang.org/ .SH AUTHOR GRacket was implemented by Matthew Flatt (mflatt@racket-lang.org), diff --git a/man/man1/mred.1 b/man/man1/mred.1 index 4c46b27a..ca8f3557 100644 --- a/man/man1/mred.1 +++ b/man/man1/mred.1 @@ -33,7 +33,7 @@ Alternately, consult the on-line documentation and other information available at .PP .ce 1 -http://www.racket-lang.org/ +http://racket-lang.org/ .SH SEE ALSO .BR gracket(1) diff --git a/man/man1/mzscheme.1 b/man/man1/mzscheme.1 index ae104ad2..32224a73 100644 --- a/man/man1/mzscheme.1 +++ b/man/man1/mzscheme.1 @@ -33,7 +33,7 @@ Alternately, consult the on-line documentation and other information available at .PP .ce 1 -http://www.racket-lang.org/ +http://racket-lang.org/ .SH SEE ALSO .BR racket(1)