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 fry combinators.short-circuit ;
   8 IN: ui.tools.browser
   9
  10 TUPLE: browser-gadget < track pane history ;
  11
  12 : show-help ( link help -- )
  13     history>> dup add-history
  14     [ >link ] dip set-model ;
  15
  16 : <help-pane> ( browser-gadget -- gadget )
  17     history>> [ '[ _ print-topic ] 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         add-toolbar
  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     {
  42         [ key? ]
  43         [ [ dup word-link? [ name>> ] when ] dip key? ]
  44         [ [ dup vocab-link? [ vocab ] when ] dip key? ]
  45     } 2|| ;
  46
  47 M: browser-gadget definitions-changed ( assoc browser -- )
  48     history>>
  49     dup value>> rot showing-definition?
  50     [ notify-connections ] [ drop ] if ;
  51
  52 : help-action ( browser-gadget -- link )
  53     history>> value>> >link ;
  54
  55 : com-follow ( link -- ) browser-gadget call-tool ;
  56
  57 : com-back ( browser -- ) history>> go-back ;
  58
  59 : com-forward ( browser -- ) history>> go-forward ;
  60
  61 : com-documentation ( browser -- ) "handbook" swap show-help ;
  62
  63 : com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
  64
  65 : browser-help ( -- ) "ui-browser" help-window ;
  66
  67 \ browser-help H{ { +nullary+ t } } define-command
  68
  69 browser-gadget "toolbar" f {
  70     { T{ key-down f { A+ } "LEFT" } com-back }
  71     { T{ key-down f { A+ } "RIGHT" } com-forward }
  72     { f com-documentation }
  73     { f com-vocabularies }
  74     { T{ key-down f f "F1" } browser-help }
  75 } define-command-map
  76
  77 browser-gadget "multi-touch" f {
  78     { T{ left-action } com-back }
  79     { T{ right-action } com-forward }
  80 } define-command-map