1 ! Copyright (C) 2006, 2007 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: classes continuations help help.topics kernel models
4 sequences ui ui.backend ui.tools.debugger ui.gadgets
5 ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
6 ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
7 ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
8 ui.commands ui.gestures assocs arrays namespaces accessors ;
10 IN: ui.tools.workspace
12 TUPLE: workspace < track book listener popup ;
14 : find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
16 SYMBOL: workspace-window-hook
18 : workspace-window* ( -- workspace ) workspace-window-hook get call ;
20 : workspace-window ( -- ) workspace-window* drop ;
22 GENERIC: call-tool* ( arg tool -- )
24 GENERIC: tool-scroller ( tool -- scroller )
26 M: gadget tool-scroller drop f ;
28 : find-tool ( class workspace -- index tool )
29 book>> children>> [ class eq? ] with find ;
31 : show-tool ( class workspace -- tool )
32 [ find-tool swap ] keep book>> model>>
35 : select-tool ( workspace class -- ) swap show-tool drop ;
37 : get-workspace* ( quot -- workspace )
38 [ >r dup workspace? r> [ drop f ] if ] curry find-window
39 [ dup raise-window gadget-child ]
40 [ workspace-window* ] if* ; inline
42 : get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
44 : call-tool ( arg class -- )
45 get-workspace show-tool call-tool* ;
47 : get-tool ( class -- gadget )
48 get-workspace find-tool nip ;
50 : help-window ( topic -- )
52 <pane> [ [ help ] with-pane ] keep
53 { 550 700 } <limited-scroller>
55 article-title open-window ;
57 : hide-popup ( workspace -- )
58 dup popup>> track-remove
62 : show-popup ( gadget workspace -- )
68 : show-titled-popup ( workspace gadget title -- )
69 [ find-workspace hide-popup ] <closable-gadget>
72 : debugger-popup ( error workspace -- )
73 swap dup compute-restarts
74 [ find-workspace hide-popup ] <debugger>
75 "Error" show-titled-popup ;
79 { 600 700 } workspace-dim set-global
81 M: workspace pref-dim* drop workspace-dim get ;
83 M: workspace focusable-child*
84 dup popup>> [ ] [ listener>> ] ?if ;
86 : workspace-page ( workspace -- gadget )
89 M: workspace tool-scroller ( workspace -- scroller )
90 workspace-page tool-scroller ;
92 : com-scroll-up ( workspace -- )
93 tool-scroller [ scroll-up-page ] when* ;
95 : com-scroll-down ( workspace -- )
96 tool-scroller [ scroll-down-page ] when* ;
99 "The current tool's scroll pane can be scrolled from the keyboard."
101 { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
102 { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }