From 508b4201e6de326d85019c522f269495fce4af46 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 23 Apr 2002 22:06:16 +0000 Subject: [PATCH] .. original commit: 237d76da871aef389fa77c25acb03fec01b01fa9 --- collects/framework/framework.ss | 140 +++++++++++- collects/framework/private/panel.ss | 70 +++--- collects/framework/private/sig.ss | 323 ++++++++++++++++++++-------- 3 files changed, 410 insertions(+), 123 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 6da0c0b6..430d65a5 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -15,10 +15,148 @@ "macro.ss" "specs.ss") - (provide-signature-elements framework^) + (provide-signature-elements framework-class^) + (provide-signature-elements ((unit test : framework:test^) + (unit gui-utils : framework:gui-utils^))) (provide (all-from "macro.ss")) (provide (all-from "specs.ss")) + (provide exn:struct:during-preferences + exn:struct:unknown-preference + exn:struct:exn) + + (provide/contract + (version:add-spec any?) + (version:version any?) + (exn:make-exn any?) + (exn:exn? any?) + (exn:make-unknown-preference any?) + (exn:unknown-preference? any?) + (exn:make-during-preferences any?) + (exn:during-preferences? any?) + (application:current-app-name any?) + (preferences:get any?) + (preferences:add-callback any?) + (preferences:set any?) + (preferences:set-default any?) + (preferences:set-un/marshall any?) + (preferences:save any?) + (preferences:read any?) + (preferences:restore-defaults any?) + (preferences:add-panel any?) + (preferences:add-font-panel any?) + (preferences:add-general-panel any?) + (preferences:show-dialog any?) + (preferences:hide-dialog any?) + (autosave:register any?) + (exit:frame-exiting any?) + (exit:insert-on-callback any?) + (exit:insert-can?-callback any?) + (exit:can-exit? any?) + (exit:on-exit any?) + (exit:exit any?) + (path-utils:generate-autosave-name any?) + (path-utils:generate-backup-name any?) + (finder:dialog-parent-parameter any?) + (finder:default-extension any?) + (finder:default-filters any?) + (finder:common-put-file any?) + (finder:common-get-file any?) + (finder:std-put-file any?) + (finder:std-get-file any?) + (finder:common-get-file-list any?) + (finder:get-file any?) + (finder:put-file any?) + (editor:basic-mixin any?) + (editor:keymap-mixin any?) + (editor:autowrap-mixin any?) + (editor:info-mixin any?) + (editor:file-mixin any?) + (editor:backup-autosave-mixin any?) + (text:basic-mixin any?) + (text:hide-caret/selection-mixin any?) + (text:delegate-mixin any?) + (text:searching-mixin any?) + (text:return-mixin any?) + (text:info-mixin any?) + (text:clever-file-format-mixin any?) + (canvas:basic-mixin any?) + (canvas:delegate-mixin any?) + (canvas:info-mixin any?) + (canvas:wide-snip-mixin any?) + (frame:reorder-menus any?) + (frame:basic-mixin any?) + (frame:standard-menus-mixin any?) + (frame:editor-mixin any?) + (frame:text-mixin any?) + (frame:pasteboard-mixin any?) + (frame:delegate-mixin any?) + (frame:searchable-mixin any?) + (frame:searchable-text-mixin any?) + (frame:info-mixin any?) + (frame:text-info-mixin any?) + (frame:pasteboard-info-mixin any?) + (frame:file-mixin any?) + (group:get-the-frame-group any?) + (handler:handler? any?) + (handler:handler-name any?) + (handler:handler-extension any?) + (handler:handler-handler any?) + (handler:insert-format-handler any?) + (handler:find-format-handler any?) + (handler:find-named-format-handler any?) + (handler:edit-file any?) + (handler:open-file any?) + (handler:install-recent-items any?) + (handler:add-to-recent any?) + (icon:get-paren-highlight-bitmap any?) + (icon:get-autowrap-bitmap any?) + (icon:get-lock-bitmap any?) + (icon:get-unlock-bitmap any?) + (icon:get-anchor-bitmap any?) + (icon:get-left/right-cursor any?) + (icon:get-up/down-cursor any?) + (icon:get-gc-on-bitmap any?) + (icon:get-gc-off-bitmap any?) + (keymap:send-map-function-meta any?) + (keymap:make-meta-prefix-list any?) + (keymap:aug-keymap-mixin any?) + (keymap:canonicalize-keybinding-string any?) + (keymap:add-to-right-button-menu any?) + (keymap:add-to-right-button-menu/before any?) + (keymap:setup-global any?) + (keymap:setup-search any?) + (keymap:setup-file any?) + (keymap:setup-editor any?) + (keymap:get-global any?) + (keymap:get-search any?) + (keymap:get-file any?) + (keymap:get-editor any?) + (keymap:call/text-keymap-initializer any?) + (scheme-paren:get-comments any?) + (scheme-paren:get-paren-pairs any?) + (scheme-paren:get-quote-pairs any?) + (scheme-paren:forward-match any?) + (scheme-paren:backward-match any?) + (scheme-paren:balanced? any?) + (scheme-paren:backward-containing-sexp any?) + (scheme:get-wordbreak-map any?) + (scheme:init-wordbreak-map any?) + (scheme:get-style-list any?) + (scheme:set-sexp-snip-class any?) + (scheme:get-sexp-snip-class any?) + (scheme:get-keymap any?) + (scheme:setup-keymap any?) + (scheme:text-mixin any?) + (scheme:add-preferences-panel any?) + (paren:balanced? any?) + (paren:forward-match any?) + (paren:backward-match any?) + (paren:skip-whitespace any?) + (color-model:rgb-color-distance any?) + (color-model:rgb->xyz any?) + (color-model:xyz->rgb any?)) + (define-values/invoke-unit/sig frameworkc^ frameworkc@ diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index bc5443d7..1324f94a 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -260,40 +260,42 @@ (rename [super-on-subwindow-event on-subwindow-event]) (inherit set-cursor) (define/override (on-subwindow-event receiver evt) - (let ([gap - (ormap (lambda (gap) - (and (<= (gap-before-y gap) (send evt get-y) (gap-after-y gap)) - gap)) - cursor-gaps)]) - (set-cursor (and (or gap - resizing-y) - (send (icon:get-up/down-cursor) ok?) - (icon:get-up/down-cursor))) - (cond - [(and gap (send evt button-down? 'left)) - (set! resizing-y (send evt get-y)) - (set! resizing-gap gap)] - [(and resizing-y (send evt button-up?)) - (set! resizing-y #f) - (set! resizing-gap #f)] - [(and resizing-y (send evt moving?)) - (let-values ([(width height) (get-client-size)]) - (let* ([before (gap-before resizing-gap)] - [before-percentage (gap-before-percentage resizing-gap)] - [after (gap-after resizing-gap)] - [after-percentage (gap-after-percentage resizing-gap)] - [available-height (get-available-height)] - [change-in-percentage (/ (- resizing-y (send evt get-y)) available-height)] - [new-before (- (percentage-% before-percentage) change-in-percentage)] - [new-after (+ (percentage-% after-percentage) change-in-percentage)]) - (when (and ((* new-before available-height) . > . (send before min-height)) - ((* new-after available-height) . > . (send after min-height))) - (set-percentage-%! before-percentage new-before) - (set-percentage-%! after-percentage new-after) - (after-percentage-change) - (set! resizing-y (send evt get-y)) - (container-flow-modified))))] - [else (super-on-subwindow-event receiver evt)]))) + (if (eq? receiver this) + (let ([gap + (ormap (lambda (gap) + (and (<= (gap-before-y gap) (send evt get-y) (gap-after-y gap)) + gap)) + cursor-gaps)]) + (set-cursor (and (or gap + resizing-y) + (send (icon:get-up/down-cursor) ok?) + (icon:get-up/down-cursor))) + (cond + [(and gap (send evt button-down? 'left)) + (set! resizing-y (send evt get-y)) + (set! resizing-gap gap)] + [(and resizing-y (send evt button-up?)) + (set! resizing-y #f) + (set! resizing-gap #f)] + [(and resizing-y (send evt moving?)) + (let-values ([(width height) (get-client-size)]) + (let* ([before (gap-before resizing-gap)] + [before-percentage (gap-before-percentage resizing-gap)] + [after (gap-after resizing-gap)] + [after-percentage (gap-after-percentage resizing-gap)] + [available-height (get-available-height)] + [change-in-percentage (/ (- resizing-y (send evt get-y)) available-height)] + [new-before (- (percentage-% before-percentage) change-in-percentage)] + [new-after (+ (percentage-% after-percentage) change-in-percentage)]) + (when (and ((* new-before available-height) . > . (send before min-height)) + ((* new-after available-height) . > . (send after min-height))) + (set-percentage-%! before-percentage new-before) + (set-percentage-%! after-percentage new-after) + (after-percentage-change) + (set! resizing-y (send evt get-y)) + (container-flow-modified))))] + [else (super-on-subwindow-event receiver evt)])) + (super-on-subwindow-event receiver evt))) (define cursor-gaps null) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 6da7afd1..69a75402 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -3,32 +3,82 @@ (require (lib "unitsig.ss")) (provide framework:menu^ + framework:menu-class^ + framework:menu-fun^ framework:version^ + framework:version-class^ + framework:version-fun^ framework:panel^ + framework:panel-class^ + framework:panel-fun^ framework:exn^ + framework:exn-class^ + framework:exn-fun^ framework:application^ + framework:application-class^ + framework:application-fun^ framework:preferences^ + framework:preferences-class^ + framework:preferences-fun^ framework:autosave^ + framework:autosave-class^ + framework:autosave-fun^ framework:exit^ + framework:exit-class^ + framework:exit-fun^ framework:path-utils^ + framework:path-utils-class^ + framework:path-utils-fun^ framework:finder^ + framework:finder-class^ + framework:finder-fun^ framework:editor^ + framework:editor-class^ + framework:editor-fun^ framework:pasteboard^ + framework:pasteboard-class^ + framework:pasteboard-fun^ framework:text^ + framework:text-class^ + framework:text-fun^ framework:canvas^ + framework:canvas-class^ + framework:canvas-fun^ framework:frame^ + framework:frame-class^ + framework:frame-fun^ framework:group^ + framework:group-class^ + framework:group-fun^ framework:handler^ + framework:handler-class^ + framework:handler-fun^ framework:icon^ + framework:icon-class^ + framework:icon-fun^ framework:keymap^ + framework:keymap-class^ + framework:keymap-fun^ framework:match-cache^ + framework:match-cache-class^ + framework:match-cache-fun^ framework:scheme-paren^ + framework:scheme-paren-class^ + framework:scheme-paren-fun^ framework:scheme^ + framework:scheme-class^ + framework:scheme-fun^ framework:paren^ + framework:paren-class^ + framework:paren-fun^ framework:main^ - framework:color-model^) + framework:main-class^ + framework:main-fun^ + framework:color-model^ + framework:color-model-class^ + framework:color-model-fun^) - (define-signature framework:menu^ + (define-signature framework:menu-class^ (can-restore<%> can-restore-mixin can-restore-underscore<%> @@ -36,12 +86,22 @@ can-restore-menu-item% can-restore-checkable-menu-item% can-restore-underscore-menu%)) + (define-signature framework:menu-fun^ + ()) + (define-signature framework:menu^ + ((open framework:menu-class^) + (open framework:menu-fun^))) - (define-signature framework:version^ + (define-signature framework:version-class^ + ()) + (define-signature framework:version-fun^ (add-spec version)) + (define-signature framework:version^ + ((open framework:version-class^) + (open framework:version-fun^))) - (define-signature framework:panel^ + (define-signature framework:panel-class^ (single-mixin single<%> @@ -59,16 +119,33 @@ vertical-dragable<%> vertical-dragable-mixin vertical-dragable%)) + (define-signature framework:panel-fun^ + ()) + (define-signature framework:panel^ + ((open framework:panel-class^) + (open framework:panel-fun^))) - (define-signature framework:exn^ + (define-signature framework:exn-class^ + ()) + (define-signature framework:exn-fun^ ((struct exn ()) (struct unknown-preference ()) (struct during-preferences ()))) + (define-signature framework:exn^ + ((open framework:exn-class^) + (open framework:exn-fun^))) - (define-signature framework:application^ + (define-signature framework:application-class^ + ()) + (define-signature framework:application-fun^ (current-app-name)) + (define-signature framework:application^ + ((open framework:application-class^) + (open framework:application-fun^))) - (define-signature framework:preferences^ + (define-signature framework:preferences-class^ + ()) + (define-signature framework:preferences-fun^ (get add-callback set @@ -84,23 +161,43 @@ add-general-panel show-dialog hide-dialog)) + (define-signature framework:preferences^ + ((open framework:preferences-class^) + (open framework:preferences-fun^))) - (define-signature framework:autosave^ + (define-signature framework:autosave-class^ + ()) + (define-signature framework:autosave-fun^ (register)) + (define-signature framework:autosave^ + ((open framework:autosave-class^) + (open framework:autosave-fun^))) - (define-signature framework:exit^ + (define-signature framework:exit-class^ + ()) + (define-signature framework:exit-fun^ (frame-exiting insert-on-callback insert-can?-callback can-exit? on-exit exit)) + (define-signature framework:exit^ + ((open framework:exit-class^) + (open framework:exit-fun^))) - (define-signature framework:path-utils^ + (define-signature framework:path-utils-class^ + ()) + (define-signature framework:path-utils-fun^ (generate-autosave-name generate-backup-name)) + (define-signature framework:path-utils^ + ((open framework:path-utils-class^) + (open framework:path-utils-fun^))) - (define-signature framework:finder^ + (define-signature framework:finder-class^ + ()) + (define-signature framework:finder-fun^ (dialog-parent-parameter default-extension default-filters @@ -111,30 +208,41 @@ common-get-file-list get-file put-file)) + (define-signature framework:finder^ + ((open framework:finder-class^) + (open framework:finder-fun^))) - (define-signature framework:editor^ + (define-signature framework:editor-class^ (basic<%> keymap<%> autowrap<%> info<%> file<%> - backup-autosave<%> - - basic-mixin + backup-autosave<%>)) + (define-signature framework:editor-fun^ + (basic-mixin keymap-mixin autowrap-mixin info-mixin file-mixin backup-autosave-mixin)) + (define-signature framework:editor^ + ((open framework:editor-class^) + (open framework:editor-fun^))) - (define-signature framework:pasteboard^ + (define-signature framework:pasteboard-class^ (basic% keymap% file% backup-autosave% info%)) + (define-signature framework:pasteboard-fun^ + ()) + (define-signature framework:pasteboard^ + ((open framework:pasteboard-class^) + (open framework:pasteboard-fun^))) - (define-signature framework:text^ + (define-signature framework:text-class^ (basic<%> hide-caret/selection<%> delegate<%> @@ -143,14 +251,6 @@ info<%> clever-file-format<%> - basic-mixin - hide-caret/selection-mixin - delegate-mixin - searching-mixin - return-mixin - info-mixin - clever-file-format-mixin - basic% hide-caret/selection% 1-pixel-string-snip% @@ -164,85 +264,93 @@ backup-autosave% searching% info%)) - - (define-signature framework:canvas^ + (define-signature framework:text-fun^ (basic-mixin - basic<%> - + hide-caret/selection-mixin delegate-mixin - delegate<%> - + searching-mixin + return-mixin info-mixin + clever-file-format-mixin)) + (define-signature framework:text^ + ((open framework:text-class^) + (open framework:text-fun^))) + + (define-signature framework:canvas-class^ + (basic<%> + delegate<%> info<%> - - wide-snip-mixin wide-snip<%> - wide-snip% basic% info%)) - - (define-signature framework:frame^ - (reorder-menus - - basic<%> - basic-mixin - - standard-menus<%> - standard-menus-mixin - - editor<%> - editor-mixin - - text<%> - text-mixin - - pasteboard<%> - pasteboard-mixin - - delegate<%> + (define-signature framework:canvas-fun^ + (basic-mixin delegate-mixin - - searchable<%> - searchable-mixin - - searchable-text<%> - searchable-text-mixin - - info<%> info-mixin + wide-snip-mixin)) + (define-signature framework:canvas^ + ((open framework:canvas-class^) + (open framework:canvas-fun^))) + (define-signature framework:frame-class^ + (basic<%> + standard-menus<%> + editor<%> + text<%> + pasteboard<%> + delegate<%> + searchable<%> + searchable-text<%> + info<%> text-info<%> - text-info-mixin - pasteboard-info<%> - pasteboard-info-mixin - file<%> - file-mixin - basic% info% text-info% pasteboard-info% standard-menus% editor% - text% text-info-file% searchable% delegate% pasteboard% pasteboard-info-file%)) + (define-signature framework:frame-fun^ + (reorder-menus + basic-mixin + standard-menus-mixin + editor-mixin + text-mixin + pasteboard-mixin + delegate-mixin + searchable-mixin + searchable-text-mixin + info-mixin + text-info-mixin + pasteboard-info-mixin + file-mixin)) + (define-signature framework:frame^ + ((open framework:frame-class^) + (open framework:frame-fun^))) + (define-signature framework:group-class^ + (%)) + (define-signature framework:group-fun^ + (get-the-frame-group)) (define-signature framework:group^ - (% - get-the-frame-group)) + ((open framework:group-class^) + (open framework:group-fun^))) - (define-signature framework:handler^ + (define-signature framework:handler-class^ + ()) + (define-signature framework:handler-fun^ (handler? handler-name - handler-extension handler-handler + handler-extension + handler-handler insert-format-handler find-format-handler find-named-format-handler @@ -250,8 +358,13 @@ open-file install-recent-items add-to-recent)) + (define-signature framework:handler^ + ((open framework:handler-class^) + (open framework:handler-fun^))) - (define-signature framework:icon^ + (define-signature framework:icon-class^ + ()) + (define-signature framework:icon-fun^ (get-paren-highlight-bitmap get-autowrap-bitmap @@ -264,14 +377,18 @@ get-gc-on-bitmap get-gc-off-bitmap)) + (define-signature framework:icon^ + ((open framework:icon-class^) + (open framework:icon-fun^))) - (define-signature framework:keymap^ + (define-signature framework:keymap-class^ + (aug-keymap% + aug-keymap<%>)) + (define-signature framework:keymap-fun^ (send-map-function-meta make-meta-prefix-list aug-keymap-mixin - aug-keymap% - aug-keymap<%> canonicalize-keybinding-string @@ -289,11 +406,21 @@ get-editor call/text-keymap-initializer)) + (define-signature framework:keymap^ + ((open framework:keymap-class^) + (open framework:keymap-fun^))) - (define-signature framework:match-cache^ + (define-signature framework:match-cache-class^ (%)) + (define-signature framework:match-cache-fun^ + ()) + (define-signature framework:match-cache^ + ((open framework:match-cache-class^) + (open framework:match-cache-fun^))) - (define-signature framework:scheme-paren^ + (define-signature framework:scheme-paren-class^ + ()) + (define-signature framework:scheme-paren-fun^ (get-comments get-paren-pairs get-quote-pairs @@ -301,30 +428,50 @@ backward-match balanced? backward-containing-sexp)) + (define-signature framework:scheme-paren^ + ((open framework:scheme-paren-class^) + (open framework:scheme-paren-fun^))) - (define-signature framework:scheme^ + (define-signature framework:scheme-class^ + (text<%> + text%)) + (define-signature framework:scheme-fun^ (get-wordbreak-map init-wordbreak-map - get-style-list - set-sexp-snip-class get-sexp-snip-class - get-keymap setup-keymap text-mixin - text<%> - text% add-preferences-panel)) + (define-signature framework:scheme^ + ((open framework:scheme-class^) + (open framework:scheme-fun^))) - (define-signature framework:paren^ + (define-signature framework:paren-class^ + ()) + (define-signature framework:paren-fun^ (balanced? forward-match backward-match skip-whitespace)) + (define-signature framework:paren^ + ((open framework:paren-class^) + (open framework:paren-fun^))) - (define-signature framework:main^ ()) + (define-signature framework:main-class^ ()) + (define-signature framework:main-fun^ ()) + (define-signature framework:main^ + ((open framework:main-class^) + (open framework:main-fun^))) + (define-signature framework:color-model-class^ + ()) + (define-signature framework:color-model-fun^ + (rgb-color-distance + rgb->xyz + xyz->rgb)) (define-signature framework:color-model^ - (rgb-color-distance rgb->xyz xyz->rgb))) + ((open framework:color-model-class^) + (open framework:color-model-fun^))))