basis/ui/tools/workspace/workspace.factor

   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 ;
   9
  10 IN: ui.tools.workspace
  11
  12 TUPLE: workspace < track book listener popup ;
  13
  14 : find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
  15
  16 SYMBOL: workspace-window-hook
  17
  18 : workspace-window* ( -- workspace ) workspace-window-hook get call ;
  19
  20 : workspace-window ( -- ) workspace-window* drop ;
  21
  22 GENERIC: call-tool* ( arg tool -- )
  23
  24 GENERIC: tool-scroller ( tool -- scroller )
  25
  26 M: gadget tool-scroller drop f ;
  27
  28 : find-tool ( class workspace -- index tool )
  29     book>> children>> [ class eq? ] with find ;
  30
  31 : show-tool ( class workspace -- tool )
  32     [ find-tool swap ] keep book>> model>>
  33     set-model ;
  34
  35 : select-tool ( workspace class -- ) swap show-tool drop ;
  36
  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
  41
  42 : get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
  43
  44 : call-tool ( arg class -- )
  45     get-workspace show-tool call-tool* ;
  46
  47 : get-tool ( class -- gadget )
  48     get-workspace find-tool nip ;
  49
  50 : help-window ( topic -- )
  51     [
  52         <pane> [ [ help ] with-pane ] keep
  53         { 550 700 } <limited-scroller>
  54     ] keep
  55     article-title open-window ;
  56
  57 : hide-popup ( workspace -- )
  58     dup popup>> track-remove
  59     f >>popup
  60     request-focus ;
  61
  62 : show-popup ( gadget workspace -- )
  63     dup hide-popup
  64     over >>popup
  65     over f track-add drop
  66     request-focus ;
  67
  68 : show-titled-popup ( workspace gadget title -- )
  69     [ find-workspace hide-popup ] <closable-gadget>
  70     swap show-popup ;
  71
  72 : debugger-popup ( error workspace -- )
  73     swap dup compute-restarts
  74     [ find-workspace hide-popup ] <debugger>
  75     "Error" show-titled-popup ;
  76
  77 SYMBOL: workspace-dim
  78
  79 { 600 700 } workspace-dim set-global
  80
  81 M: workspace pref-dim* drop workspace-dim get ;
  82
  83 M: workspace focusable-child*
  84     dup popup>> [ ] [ listener>> ] ?if ;
  85
  86 : workspace-page ( workspace -- gadget )
  87     book>> current-page ;
  88
  89 M: workspace tool-scroller ( workspace -- scroller )
  90     workspace-page tool-scroller ;
  91
  92 : com-scroll-up ( workspace -- )
  93     tool-scroller [ scroll-up-page ] when* ;
  94
  95 : com-scroll-down ( workspace -- )
  96     tool-scroller [ scroll-down-page ] when* ;
  97
  98 workspace "scrolling"
  99 "The current tool's scroll pane can be scrolled from the keyboard."
 100 {
 101     { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
 102     { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
 103 } define-command-map