core/ui/tools/tools.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-messages
   4 DEFER: messages
   5
   6 IN: gadgets-workspace
   7 USING: gadgets gadgets-books gadgets-workspace
   8 generic kernel models scratchpad sequences syntax
   9 gadgets-messages ;
  10
  11 DEFER: workspace-window
  12
  13 GENERIC: call-tool* ( arg tool -- )
  14
  15 GENERIC: tool-scroller ( tool -- scroller )
  16
  17 M: gadget tool-scroller drop f ;
  18
  19 GENERIC: tool-help ( tool -- topic )
  20
  21 M: gadget tool-help drop f ;
  22
  23 TUPLE: workspace book popup error-hook ;
  24
  25 : find-workspace [ workspace? ] find-parent ;
  26
  27 TUPLE: tool gadget ;
  28
  29 : find-tool ( class workspace -- index tool )
  30     workspace-book gadget-children
  31     [ tool-gadget class eq? ] find-with ;
  32
  33 : show-tool ( class workspace -- tool )
  34     [ find-tool swap ] keep workspace-book control-model
  35     set-model ;
  36
  37 : select-tool ( workspace class -- ) swap show-tool drop ;
  38
  39 : get-workspace* ( quot -- workspace )
  40     [ dup workspace? [ over call ] [ drop f ] if ] find-window
  41     [ nip dup raise-window world-gadget ]
  42     [ workspace-window drop get-workspace* ] if* ; inline
  43
  44 : get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
  45
  46 : call-tool ( arg class -- )
  47     get-workspace show-tool call-tool* ;
  48
  49 : get-tool ( class -- gadget )
  50     get-workspace find-tool nip tool-gadget ;
  51
  52 : find-messages ( -- gadget ) messages get-tool ;