2007-09-20 18:09:08 -04:00
|
|
|
! Copyright (C) 2006, 2007 Slava Pestov.
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
|
USING: classes continuations help help.topics kernel models
|
|
|
|
|
sequences ui ui.backend ui.tools.debugger ui.gadgets
|
2007-11-24 22:09:40 -05:00
|
|
|
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
|
|
|
|
|
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
|
|
|
|
|
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
|
|
|
|
|
ui.commands ui.gestures assocs arrays namespaces ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: ui.tools.workspace
|
|
|
|
|
|
|
|
|
|
TUPLE: workspace book listener popup ;
|
|
|
|
|
|
|
|
|
|
: find-workspace [ workspace? ] find-parent ;
|
|
|
|
|
|
|
|
|
|
SYMBOL: workspace-window-hook
|
|
|
|
|
|
2008-03-01 02:46:01 -05:00
|
|
|
: workspace-window* ( -- workspace )
|
2007-09-20 18:09:08 -04:00
|
|
|
workspace-window-hook get call ;
|
|
|
|
|
|
2008-03-01 02:46:01 -05:00
|
|
|
: workspace-window ( -- )
|
|
|
|
|
workspace-window* drop ;
|
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
GENERIC: call-tool* ( arg tool -- )
|
|
|
|
|
|
|
|
|
|
GENERIC: tool-scroller ( tool -- scroller )
|
|
|
|
|
|
|
|
|
|
M: gadget tool-scroller drop f ;
|
|
|
|
|
|
|
|
|
|
: find-tool ( class workspace -- index tool )
|
2008-01-09 17:36:30 -05:00
|
|
|
workspace-book gadget-children [ class eq? ] with find ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
: show-tool ( class workspace -- tool )
|
2007-11-14 16:35:17 -05:00
|
|
|
[ find-tool swap ] keep workspace-book gadget-model
|
2007-09-20 18:09:08 -04:00
|
|
|
set-model ;
|
|
|
|
|
|
|
|
|
|
: select-tool ( workspace class -- ) swap show-tool drop ;
|
|
|
|
|
|
|
|
|
|
: get-workspace* ( quot -- workspace )
|
2008-03-01 02:46:01 -05:00
|
|
|
[ >r dup workspace? r> [ drop f ] if ] curry find-window
|
|
|
|
|
[ dup raise-window gadget-child ]
|
|
|
|
|
[ workspace-window* ] if* ; inline
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
|
|
|
|
|
|
|
|
|
|
: call-tool ( arg class -- )
|
|
|
|
|
get-workspace show-tool call-tool* ;
|
|
|
|
|
|
|
|
|
|
: get-tool ( class -- gadget )
|
|
|
|
|
get-workspace find-tool nip ;
|
|
|
|
|
|
|
|
|
|
: help-window ( topic -- )
|
|
|
|
|
[ <pane> [ [ help ] with-pane ] keep <scroller> ] keep
|
|
|
|
|
article-title open-window ;
|
|
|
|
|
|
|
|
|
|
: hide-popup ( workspace -- )
|
|
|
|
|
dup workspace-popup over track-remove
|
|
|
|
|
f over set-workspace-popup
|
|
|
|
|
request-focus ;
|
|
|
|
|
|
|
|
|
|
: show-popup ( gadget workspace -- )
|
|
|
|
|
dup hide-popup
|
|
|
|
|
2dup set-workspace-popup
|
|
|
|
|
dupd f track-add
|
|
|
|
|
request-focus ;
|
|
|
|
|
|
|
|
|
|
: show-titled-popup ( workspace gadget title -- )
|
|
|
|
|
[ find-workspace hide-popup ] <closable-gadget>
|
|
|
|
|
swap show-popup ;
|
|
|
|
|
|
|
|
|
|
: debugger-popup ( error workspace -- )
|
|
|
|
|
swap dup compute-restarts
|
|
|
|
|
[ find-workspace hide-popup ] <debugger>
|
|
|
|
|
"Error" show-titled-popup ;
|
|
|
|
|
|
2008-01-30 02:59:46 -05:00
|
|
|
SYMBOL: workspace-dim
|
|
|
|
|
|
|
|
|
|
{ 600 700 } workspace-dim set-global
|
|
|
|
|
|
|
|
|
|
M: workspace pref-dim* drop workspace-dim get ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
M: workspace focusable-child*
|
|
|
|
|
dup workspace-popup [ ] [ workspace-listener ] ?if ;
|
|
|
|
|
|
|
|
|
|
: workspace-page ( workspace -- gadget )
|
|
|
|
|
workspace-book current-page ;
|
|
|
|
|
|
|
|
|
|
M: workspace tool-scroller ( workspace -- scroller )
|
|
|
|
|
workspace-page tool-scroller ;
|
|
|
|
|
|
|
|
|
|
: com-scroll-up ( workspace -- )
|
|
|
|
|
tool-scroller [ scroll-up-page ] when* ;
|
|
|
|
|
|
|
|
|
|
: com-scroll-down ( workspace -- )
|
|
|
|
|
tool-scroller [ scroll-down-page ] when* ;
|
|
|
|
|
|
|
|
|
|
workspace "scrolling"
|
|
|
|
|
"The current tool's scroll pane can be scrolled from the keyboard."
|
|
|
|
|
{
|
|
|
|
|
{ T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
|
|
|
|
|
{ T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
|
|
|
|
|
} define-command-map
|
