Improved deploy tool

release
Slava Pestov 2007-11-01 13:50:02 -04:00
parent 0f46ff8a15
commit 8c87610fc6
5 changed files with 36 additions and 22 deletions

View File

@ -12,3 +12,5 @@ vocabs vocabs.loader ;
"ui.freetype" require
] when
macosx? [ "ui.tools.deploy" require ] when

View File

@ -37,13 +37,6 @@ TUPLE: loc-monitor editor ;
: field-theme ( gadget -- )
gray <solid> swap set-gadget-boundary ;
: <field> ( model -- gadget )
drop
<editor>
2 <border>
{ 1 0 } over set-border-fill
dup field-theme ;
: construct-editor ( class -- tuple )
>r <editor> { set-gadget-delegate } r>
(construct-control) ; inline
@ -435,3 +428,28 @@ M: editor stream-write
M: editor stream-close drop ;
M: editor stream-flush drop ;
! Fields are like editors except they edit an external model
TUPLE: field model editor ;
: <field-border> ( gadget -- border )
2 <border>
{ 1 0 } over set-border-fill
dup field-theme ;
: <field> ( model -- gadget )
<editor> dup <field-border>
{ set-field-model set-field-editor set-gadget-delegate }
field construct ;
M: field graft*
dup field-model model-value
over field-editor set-editor-string
dup field-editor control-model add-connection ;
M: field ungraft*
dup field-editor control-model remove-connection ;
M: field model-changed
dup field-editor editor-string
swap field-model set-model ;

View File

@ -95,7 +95,6 @@ SYMBOL: ui-error-hook
] [
over <world-error> ui-error
f swap set-world-active?
drop
] recover
] with-variable
] [

View File

@ -5,7 +5,7 @@ ui.gadgets.controls models sequences ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace ;
tools.deploy.app vocabs ui.tools.workspace ui.operations ;
IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ;
@ -43,6 +43,7 @@ TUPLE: deploy-gadget vocab settings ;
: <deploy-settings> ( -- control )
default-config [ <model> ] assoc-map [
f <model> "bundle-name" set
[
bundle-name
deploy-ui
@ -61,7 +62,7 @@ TUPLE: deploy-gadget vocab settings ;
find-deploy-gadget deploy-gadget-vocab ;
: find-deploy-config
find-deploy-vocab deploy-config ;
find-deploy-vocab deploy.app-config ;
: find-deploy-settings
find-deploy-gadget deploy-gadget-settings ;
@ -76,7 +77,7 @@ TUPLE: deploy-gadget vocab settings ;
: com-deploy ( gadget -- )
dup com-save
find-deploy-vocab [ deploy ] curry call-listener ;
find-deploy-vocab [ deploy.app ] curry call-listener ;
: com-help ( -- )
"ui-deploy" help-window ;
@ -107,3 +108,5 @@ deploy-gadget "toolbar" f {
: deploy-tool ( vocab -- )
vocab-name dup <deploy-gadget> 10 <border>
"Deploying \"" rot "\"" 3append open-window ;
[ vocab-spec? ] \ deploy-tool H{ } define-operation

View File

@ -7,8 +7,7 @@ help.topics inference inspector io.files io.styles kernel
namespaces parser prettyprint quotations tools.annotations
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations vocabs
vocabs.loader words sequences tools.browser classes
ui.tools.deploy ;
vocabs.loader words sequences tools.browser classes ;
IN: ui.tools.operations
V{ } clone operations set-global
@ -156,8 +155,6 @@ M: word com-stack-effect word-def com-stack-effect ;
{ +listener+ t }
} define-operation
[ vocab-spec? ] \ deploy-tool H{ } define-operation
! Quotations
[ quotation? ] \ com-stack-effect H{
{ +keyboard+ T{ key-down f { C+ } "i" } }
@ -184,13 +181,8 @@ M: word com-stack-effect word-def com-stack-effect ;
} define-operation
! Profiler presentations
[ usage-profile? ] \ com-show-profile H{
{ +primary+ t }
} define-operation
[ vocab-profile? ] \ com-show-profile H{
{ +primary+ t }
} define-operation
[ dup usage-profile? swap vocab-profile? or ]
\ com-show-profile H{ { +primary+ t } } define-operation
! Operations -> commands
source-editor