diff --git a/collects/drscheme/private/oc.ss b/collects/drscheme/private/oc.ss deleted file mode 100644 index d9fa607526..0000000000 --- a/collects/drscheme/private/oc.ss +++ /dev/null @@ -1,74 +0,0 @@ -#lang scheme/base -(require (for-syntax scheme/base)) - -(provide oc) - -(define-for-syntax (change-context ctxt stx) - (let loop ([stx stx]) - (cond - [(syntax? stx) - (datum->syntax ctxt (loop (syntax-e stx)) stx stx stx)] - [(pair? stx) (cons (loop (car stx)) - (loop (cdr stx)))] - [else stx]))) - -(define-syntax (oc stx) - (syntax-case stx () - [(_ ctxt) #'(oc #f ctxt)] - [(_ id ctxt) - (or (identifier? #'id) - (not (syntax-e #'id))) - (let ([main-thing - (change-context - #'ctxt - #'(object-contract - (config-panel ((is-a?/c area-container<%>) - . -> . - (case-> (any/c . -> . void?) (-> any/c)))) - (create-executable (any/c - (or/c (is-a?/c dialog%) (is-a?/c frame%)) - path? - . -> . - void?)) - (default-settings (-> any/c)) - (default-settings? (any/c . -> . boolean?)) - (order-manuals ((listof bytes?) . -> . (values (listof bytes?) boolean?))) - (front-end/complete-program (input-port? - any/c - . -> . - (-> any/c))) - (front-end/interaction (input-port? - any/c - . -> . - (-> any/c))) - (get-language-name (-> string?)) - (get-language-numbers (-> (cons/c number? (listof number?)))) - (get-language-position (-> (cons/c string? (listof string?)))) - (get-language-url (-> (or/c false/c string?))) - (get-one-line-summary (-> string?)) - (get-comment-character (-> (values string? char?))) - (get-style-delta (-> (or/c false/c - (is-a?/c style-delta%) - (listof (list/c (is-a?/c style-delta%) number? number?))))) - (marshall-settings (any/c . -> . printable/c)) - (on-execute (any/c ((-> any) . -> . any) . -> . any)) - (render-value (any/c - any/c - output-port? - . -> . - void?)) - (render-value/format (any/c - any/c - output-port? - (or/c number? (symbols 'infinity)) - . -> . - any)) - (unmarshall-settings (printable/c . -> . any)) - - (capability-value - (->d ([s (and/c symbol? drscheme:language:capability-registered?)]) - () - [res (drscheme:language:get-capability-contract s)]))))]) - (if (syntax-e #'id) - #`(id #,main-thing) - main-thing))])) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 95f9e3d596..f7683b4a4c 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -1148,7 +1148,7 @@ module browser threading seems wrong. (define-local-member-name disable-evaluation-in-tab enable-evaluation-in-tab - update-toolbar-visiblity) + update-toolbar-visibility) (define -frame<%> (interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>) @@ -1316,7 +1316,7 @@ module browser threading seems wrong. (define/private (change-toolbar-state new-state) (set! toolbar-state new-state) (preferences:set 'drscheme:toolbar-state new-state) - (update-toolbar-visiblity)) + (update-toolbar-visibility)) (define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) @@ -1324,17 +1324,12 @@ module browser threading seems wrong. (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) (define/private (set-toolbar-hidden) (change-toolbar-state (cons #t (cdr toolbar-state)))) - (define/public (update-toolbar-visiblity) - (let* ([hidden? (car (preferences:get 'drscheme:toolbar-state))] - [top? (and (not hidden?) - (eq? (cdr (preferences:get 'drscheme:toolbar-state)) - 'top))] - [right? (and (not hidden?) - (eq? (cdr (preferences:get 'drscheme:toolbar-state)) - 'right))] - [left? (and (not hidden?) - (eq? (cdr (preferences:get 'drscheme:toolbar-state)) - 'left))]) + (define/public (update-toolbar-visibility) + (let* ([hidden? (toolbar-is-hidden?)] + [left? (toolbar-is-left?)] + [right? (toolbar-is-right?)] + [top? (toolbar-is-top?)]) + (send toolbar-left-menu-item check left?) (send toolbar-right-menu-item check right?) (send toolbar-top-menu-item check top?) @@ -1345,45 +1340,66 @@ module browser threading seems wrong. (hide-info) (send top-outer-panel change-children (λ (l) '())) (send logging-parent-panel change-children (λ (l) '()))] - [top? (orient/show #f #t)] - [left? (orient/show #t #t)] - [right? (orient/show #t #f)])) + [top? (orient/show #t)] + [left? (orient/show #t)] + [right? (orient/show #f)])) (update-defs/ints-resize-corner)) - (define/private (orient/show vertical? bar-at-beginning?) - (begin-container-sequence) - (show-info) - - (let ([bpo (send button-panel get-orientation)]) - (unless (equal? bpo (not vertical?)) - (send button-panel set-orientation (not vertical?)) - - ;; have to be careful to avoid reversing the list when the orientation is already proper - (send button-panel change-children reverse))) + (define/private (toolbar-is-hidden?) + (car (preferences:get 'drscheme:toolbar-state))) + (define/private (toolbar-is-top?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drscheme:toolbar-state)) + 'top))) + (define/private (toolbar-is-right?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drscheme:toolbar-state)) + 'right))) + (define/private (toolbar-is-left?) + (and (not (toolbar-is-hidden?)) + (eq? (cdr (preferences:get 'drscheme:toolbar-state)) + 'left))) + + (define/private (orient/show bar-at-beginning?) + (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) + (begin-container-sequence) + (show-info) - (let loop ([obj button-panel]) - (cond - [(is-a? obj area-container<%>) - (for-each loop (send obj get-children))] - [(is-a? obj switchable-button%) - (send obj set-label-visible (not vertical?))] - [else (void)])) - (send save-button set-label-visible (not vertical?)) - (send top-outer-panel stretchable-height vertical?) - (send top-outer-panel stretchable-width (not vertical?)) - (send top-panel set-orientation (not vertical?)) - (send toolbar/rest-panel set-orientation vertical?) - (send toolbar/rest-panel change-children - (λ (l) - (if bar-at-beginning? - (cons top-outer-panel (remq top-outer-panel l)) - (append (remq top-outer-panel l) (list top-outer-panel))))) - (send top-outer-panel change-children (λ (l) (list top-panel))) - (send logging-parent-panel change-children (λ (l) (list logging-panel))) - (if vertical? - (send top-panel change-children (λ (x) (remq name-panel x))) - (send top-panel change-children (λ (x) (cons name-panel (remq name-panel x))))) - (end-container-sequence)) + (let ([bpo (send button-panel get-orientation)]) + (unless (equal? bpo (not vertical?)) + (send button-panel set-orientation (not vertical?)) + + ;; have to be careful to avoid reversing the list when the orientation is already proper + (send button-panel change-children reverse))) + + (orient) + + (send top-outer-panel stretchable-height vertical?) + (send top-outer-panel stretchable-width (not vertical?)) + (send top-panel set-orientation (not vertical?)) + (send toolbar/rest-panel set-orientation vertical?) + (send toolbar/rest-panel change-children + (λ (l) + (if bar-at-beginning? + (cons top-outer-panel (remq top-outer-panel l)) + (append (remq top-outer-panel l) (list top-outer-panel))))) + (send top-outer-panel change-children (λ (l) (list top-panel))) + (send logging-parent-panel change-children (λ (l) (list logging-panel))) + (if vertical? + (send top-panel change-children (λ (x) (remq name-panel x))) + (send top-panel change-children (λ (x) (cons name-panel (remq name-panel x))))) + (end-container-sequence))) + + (define/private (orient) + (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) + (let loop ([obj button-panel]) + (cond + [(is-a? obj area-container<%>) + (for-each loop (send obj get-children))] + [(is-a? obj switchable-button%) + (send obj set-label-visible (not vertical?))] + [else (void)])) + (send save-button set-label-visible (not vertical?)))) (field [remove-show-status-line-callback (preferences:add-callback @@ -3354,9 +3370,18 @@ module browser threading seems wrong. [define execute-button (void)] [define button-panel (new (class horizontal-panel% + + ;; do this so that new buttons that show up are put in the right mode + (define/override (change-children lst) + (let ([ans (super change-children lst)]) + (orient) + ans)) + (define/override (add-child c) + (super add-child c) + (orient)) (define/override (after-new-child c) - ;; do this so that new buttons that show up are put in the right mode - (update-toolbar-visiblity)) + (super after-new-child c) + (orient)) (super-new [parent top-panel] [spacing 2])))] [define/public get-execute-button (λ () execute-button)] [define/public get-break-button (λ () break-button)] @@ -3784,7 +3809,7 @@ module browser threading seems wrong. (unless (eq? (system-type) 'macosx) ;; mac os x has a bug where maximizing can make the window too big. (send frame maximize (preferences:get 'drscheme:unit-window-max?)))) - (send frame update-toolbar-visiblity) + (send frame update-toolbar-visibility) (send frame show #t) (set! first-frame? #f) frame)))) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 785a129be3..e933386227 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -8,19 +8,23 @@ the main unit, starting up drscheme. After that, it just provides all of the names in the tools library, for use defining keybindings |# -(require drscheme/private/link - drscheme/private/drsig - scheme/class +(require scheme/class scheme/gui/base scheme/unit - framework - scribble/srcdoc - framework/splash scheme/contract - drscheme/private/oc) -(require (for-syntax scheme/base)) -(require/doc drscheme/private/ts drscheme/private/oc scheme/base scribble/manual) + scheme/class + + drscheme/private/link + drscheme/private/drsig + + framework + framework/splash + + scribble/srcdoc) +(require (for-syntax scheme/base)) + +(require/doc drscheme/private/ts drscheme/private/oc scheme/base scribble/manual) (shutdown-splash) (define-values/invoke-unit/infer drscheme@) @@ -34,8 +38,67 @@ all of the names in the tools library, for use defining keybindings #'((drscheme:unit:get-program-editor-mixin) a ...)] [_ #'(drscheme:unit:get-program-editor-mixin)])) +(define-syntax (language-object-abstraction stx) + (syntax-case stx () + [(_ id) + (with-syntax ([ctc + #'(object-contract + (config-panel (-> (is-a?/c area-container<%>) + (case-> (-> any/c void?) + (-> any/c)))) + (create-executable (-> any/c + (or/c (is-a?/c dialog%) (is-a?/c frame%)) + path? + void?)) + (default-settings (-> any/c)) + (default-settings? (-> any/c boolean?)) + (order-manuals (-> (listof bytes?) + (values (listof bytes?) boolean?))) + (front-end/complete-program (-> input-port? + any/c + (-> any/c))) + (front-end/interaction (-> input-port? + any/c + (-> any/c))) + (get-language-name (-> string?)) + (get-language-numbers (-> (cons/c number? (listof number?)))) + (get-language-position (-> (cons/c string? (listof string?)))) + (get-language-url (-> (or/c false/c string?))) + (get-one-line-summary (-> string?)) + (get-comment-character (-> (values string? char?))) + (get-style-delta + (-> (or/c false/c + (is-a?/c style-delta%) + (listof + (list/c (is-a?/c style-delta%) + number? + number?))))) + (marshall-settings (-> any/c printable/c)) + (on-execute (-> any/c (-> (-> any) any) any)) + (render-value (-> any/c + any/c + output-port? + void?)) + (render-value/format (-> any/c + any/c + output-port? + (or/c number? (symbols 'infinity)) + any)) + (unmarshall-settings (-> printable/c any)) + + (capability-value + (->d ([s (and/c symbol? + drscheme:language:capability-registered?)]) + () + [res (drscheme:language:get-capability-contract s)])))]) + #'(begin + (define id ctc) + (provide/doc + (thing-doc id + contract? + @{@schemeblock[ctc]}))))])) -(define drscheme:language:object/c (oc here)) +(language-object-abstraction drscheme:language:object/c) (provide/doc @@ -1059,11 +1122,6 @@ all of the names in the tools library, for use defining keybindings ; ;;;; ;;;; - (thing-doc - drscheme:language:object/c - contract? - @{@(oc schemeblock here)}) - (proc-doc/names drscheme:language:add-snip-value (->* ((-> any/c boolean?)