basis/ui/tools/browser/browser.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: debugger ui.tools.workspace help help.topics kernel
   4 models models.history ui.commands ui.gadgets ui.gadgets.panes
   5 ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
   6 ui.gadgets.buttons compiler.units assocs words vocabs
   7 accessors ;
   8 IN: ui.tools.browser
   9
  10 TUPLE: browser-gadget < track pane history ;
  11
  12 : show-help ( link help -- )
  13     dup history>> add-history
  14     >r >link r> history>> set-model ;
  15
  16 : <help-pane> ( browser-gadget -- gadget )
  17     history>> [ [ help ] curry try ] <pane-control> ;
  18
  19 : init-history ( browser-gadget -- )
  20     "handbook" >link <history> >>history drop ;
  21
  22 : <browser-gadget> ( -- gadget )
  23     { 0 1 } browser-gadget new-track
  24         dup init-history
  25         dup <toolbar> f track-add
  26         dup <help-pane> >>pane
  27         dup pane>> <scroller> 1 track-add ;
  28
  29 M: browser-gadget call-tool* show-help ;
  30
  31 M: browser-gadget tool-scroller
  32     pane>> find-scroller ;
  33
  34 M: browser-gadget graft*
  35     [ add-definition-observer ] [ call-next-method ] bi ;
  36
  37 M: browser-gadget ungraft*
  38     [ call-next-method ] [ remove-definition-observer ] bi ;
  39
  40 : showing-definition? ( defspec assoc -- ? )
  41     [ key? ] 2keep
  42     [ >r dup word-link? [ name>> ] when r> key? ] 2keep
  43     >r dup vocab-link? [ vocab ] when r> key?
  44     or or ;
  45
  46 M: browser-gadget definitions-changed ( assoc browser -- )
  47     history>>
  48     dup value>> rot showing-definition?
  49     [ notify-connections ] [ drop ] if ;
  50
  51 : help-action ( browser-gadget -- link )
  52     history>> value>> >link ;
  53
  54 : com-follow ( link -- ) browser-gadget call-tool ;
  55
  56 : com-back ( browser -- ) history>> go-back ;
  57
  58 : com-forward ( browser -- ) history>> go-forward ;
  59
  60 : com-documentation ( browser -- ) "handbook" swap show-help ;
  61
  62 : com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
  63
  64 : browser-help ( -- ) "ui-browser" help-window ;
  65
  66 \ browser-help H{ { +nullary+ t } } define-command
  67
  68 browser-gadget "toolbar" f {
  69     { T{ key-down f { A+ } "b" } com-back }
  70     { T{ key-down f { A+ } "f" } com-forward }
  71     { T{ key-down f { A+ } "h" } com-documentation }
  72     { T{ key-down f { A+ } "v" } com-vocabularies }
  73     { T{ key-down f f "F1" } browser-help }
  74 } define-command-map
  75
  76 browser-gadget "multi-touch" f {
  77     { T{ left-action } com-back }
  78     { T{ right-action } com-forward }
  79 } define-command-map