basis/ui/tools/workspace/workspace.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes continuations help help.topics kernel models
   4 sequences assocs arrays namespaces accessors math.vectors fry ui
   5 ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
   6 ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
   7 ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
   8 ui.gadgets.presentations ui.gadgets.status-bar ui.commands
   9 ui.gestures ;
  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 : get-workspace* ( quot -- workspace )
  36     '[ dup workspace? _ [ drop f ] if ] find-window
  37     [ dup raise-window gadget-child ]
  38     [ workspace-window* ] if* ; inline
  39
  40 : get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
  41
  42 : call-tool ( arg class -- )
  43     get-workspace show-tool call-tool* ;
  44
  45 : get-tool ( class -- gadget )
  46     get-workspace find-tool nip ;
  47
  48 : <help-pane> ( topic -- pane )
  49     <pane> [ [ help ] with-pane ] keep ;
  50
  51 : help-window ( topic -- )
  52     [
  53         <help-pane> <limited-scroller>
  54             { 550 700 } >>max-dim
  55     ] [ article-title ] bi
  56     open-window ;
  57
  58 : hide-popup ( workspace -- )
  59     dup popup>> track-remove
  60     f >>popup
  61     request-focus ;
  62
  63 : show-popup ( gadget workspace -- )
  64     dup hide-popup
  65     over >>popup
  66     over f track-add drop
  67     request-focus ;
  68
  69 : show-titled-popup ( workspace gadget title -- )
  70     [ find-workspace hide-popup ] <closable-gadget>
  71     swap show-popup ;
  72
  73 : debugger-popup ( error workspace -- )
  74     swap dup compute-restarts
  75     [ find-workspace hide-popup ] <debugger>
  76     "Error" show-titled-popup ;
  77
  78 SYMBOL: workspace-dim
  79
  80 { 600 700 } workspace-dim set-global
  81
  82 M: workspace pref-dim* call-next-method workspace-dim get vmax ;
  83
  84 M: workspace focusable-child*
  85     dup popup>> [ ] [ listener>> ] ?if ;
  86
  87 : workspace-page ( workspace -- gadget )
  88     book>> current-page ;
  89
  90 M: workspace tool-scroller ( workspace -- scroller )
  91     workspace-page tool-scroller ;
  92
  93 : com-scroll-up ( workspace -- )
  94     tool-scroller [ scroll-up-page ] when* ;
  95
  96 : com-scroll-down ( workspace -- )
  97     tool-scroller [ scroll-down-page ] when* ;
  98
  99 workspace "scrolling"
 100 "The current tool's scroll pane can be scrolled from the keyboard."
 101 {
 102     { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
 103     { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
 104 } define-command-map