library/ui/tools/workspace.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-workspace
   4 USING: help arrays compiler gadgets gadgets-books
   5 gadgets-browser gadgets-buttons
   6 gadgets-dataflow gadgets-frames gadgets-grids gadgets-help
   7 gadgets-listener gadgets-presentations gadgets-walker
   8 gadgets-workspace generic kernel math modules scratchpad
   9 sequences syntax words io namespaces hashtables
  10 gadgets-scrolling gadgets-panes gadgets-messages ;
  11
  12 C: tool ( gadget -- tool )
  13     {
  14         {
  15             [ dup dup class tool 2array <toolbar> ]
  16             f
  17             f
  18             @top
  19         }
  20         {
  21             f
  22             set-tool-gadget
  23             f
  24             @center
  25         }
  26     } make-frame* ;
  27
  28 M: tool focusable-child* tool-gadget ;
  29
  30 M: tool call-tool* tool-gadget call-tool* ;
  31
  32 M: tool tool-scroller tool-gadget tool-scroller ;
  33
  34 M: tool tool-help tool-gadget tool-help ;
  35
  36 : help-window ( topic -- )
  37     [ [ help ] make-pane <scroller> ] keep
  38     article-title open-titled-window ;
  39
  40 : tool-help-window ( tool -- )
  41     tool-help [ help-window ] when* ;
  42
  43 tool "toolbar" {
  44     { "Tool help" T{ key-down f f "F1" } [ tool-help-window ] }
  45 } define-commands
  46
  47 : workspace-tabs
  48     {
  49         { "Listener" <listener-gadget> }
  50         { "Messages" <messages> }
  51         { "Definitions" <browser> }
  52         { "Documentation" <help-gadget> }
  53         { "Walker" <walker-gadget> }
  54         { "Dataflow" <dataflow-gadget> }
  55     } ;
  56
  57 C: workspace ( -- workspace )
  58     workspace-tabs [ second execute <tool> ] map <book>
  59     over set-gadget-delegate dup dup set-control-self ;
  60
  61 M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
  62
  63 : <workspace-tabs> ( book -- tabs )
  64     control-model
  65     workspace-tabs dup length [ swap first 2array ] 2map
  66     <radio-box> ;
  67
  68 : init-status ( world -- )
  69     dup world-status <presentation-help> swap @bottom grid-add ;
  70
  71 : init-tabs ( world -- )
  72     [ world-gadget <workspace-tabs> ] keep @top grid-add ;
  73
  74 : workspace-window ( -- workspace )
  75     <workspace> dup <world>
  76     [ init-status ] keep
  77     [ init-tabs ] keep
  78     open-window
  79     listener-gadget get-tool start-listener ;
  80
  81 : tool-window ( class -- ) workspace-window show-tool drop ;
  82
  83 : tool-scroll-up ( workspace -- )
  84     current-page tool-scroller [ scroll-up-page ] when* ;
  85
  86 : tool-scroll-down ( workspace -- )
  87     current-page tool-scroller [ scroll-down-page ] when* ;
  88
  89 workspace "scrolling" {
  90     { "Scroll up" T{ key-down f { C+ } "PAGE_UP" } [ tool-scroll-up ] }
  91     { "Scroll down" T{ key-down f { C+ } "PAGE_DOWN" } [ tool-scroll-down ] }
  92 } define-commands
  93
  94 workspace "tool-switch" {
  95     { "Listener" T{ key-down f f "F2" } [ listener-gadget select-tool ] }
  96     { "Messages" T{ key-down f f "F3" } [ messages select-tool ] }
  97     { "Definitions" T{ key-down f f "F4" } [ browser select-tool ] }
  98     { "Documentation" T{ key-down f f "F5" } [ help-gadget select-tool ] }
  99     { "Walker" T{ key-down f f "F6" } [ walker-gadget select-tool ] }
 100     { "Dataflow" T{ key-down f f "F7" } [ dataflow-gadget select-tool ] }
 101 } define-commands
 102
 103 workspace "tool-window" {
 104     { "New listener" T{ key-down f { S+ } "F2" } [ listener-gadget tool-window drop ] }
 105     { "New definitions" T{ key-down f { S+ } "F3" } [ browser tool-window drop ] }
 106     { "New documentation" T{ key-down f { S+ } "F4" } [ help-gadget tool-window drop ] }
 107 } define-commands
 108
 109 workspace "workflow" {
 110     { "Reload changed sources" T{ key-down f f "F8" } [ drop [ reload-modules ] call-listener ] }
 111     { "Recompile changed words" T{ key-down f { S+ } "F8" } [ drop [ recompile ] call-listener ] }
 112 } define-commands