basis/ui/tools/browser/browser.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: debugger help help.topics help.crossref kernel models compiler.units
   4 assocs words vocabs accessors fry combinators.short-circuit
   5 sequences models models.history tools.apropos combinators
   6 ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
   7 ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.packs
   8 ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
   9 ui.gadgets.glass ui.gadgets.borders ui.tools.common
  10 ui.tools.browser.popups ui ;
  11 IN: ui.tools.browser
  12
  13 TUPLE: browser-gadget < tool pane scroller search-field popup ;
  14
  15 { 650 400 } browser-gadget set-tool-dim
  16
  17 : show-help ( link browser-gadget -- )
  18     model>> dup add-history
  19     [ >link ] dip set-model ;
  20
  21 : <help-pane> ( browser-gadget -- gadget )
  22     model>> [ '[ _ print-topic ] try ] <pane-control> ;
  23
  24 : search-browser ( string browser -- )
  25     '[ <apropos> _ show-help ] unless-empty ;
  26
  27 : <search-field> ( browser -- field )
  28     '[ _ search-browser ] <action-field>
  29         10 >>min-cols
  30         10 >>max-cols ;
  31
  32 : <browser-toolbar> ( browser -- toolbar )
  33     horizontal <track>
  34         0 >>fill
  35         1/2 >>align
  36         { 5 5 } >>gap
  37         over <toolbar> f track-add
  38         swap search-field>> "Search:" label-on-left 1 track-add ;
  39
  40 : <browser-gadget> ( link -- gadget )
  41     vertical browser-gadget new-track
  42         1 >>fill
  43         swap >link <history> >>model
  44         dup <search-field> >>search-field
  45         dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
  46         dup <help-pane> >>pane
  47         dup pane>> <scroller> >>scroller
  48         dup scroller>> 1 track-add ;
  49
  50 M: browser-gadget graft*
  51     [ add-definition-observer ] [ call-next-method ] bi ;
  52
  53 M: browser-gadget ungraft*
  54     [ call-next-method ] [ remove-definition-observer ] bi ;
  55
  56 M: browser-gadget handle-gesture
  57     {
  58         { [ over key-gesture? not ] [ call-next-method ] }
  59         { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
  60         [ call-next-method ]
  61     } cond ;
  62
  63 : showing-definition? ( defspec assoc -- ? )
  64     {
  65         [ key? ]
  66         [ [ dup word-link? [ name>> ] when ] dip key? ]
  67         [ [ dup vocab-link? [ vocab ] when ] dip key? ]
  68     } 2|| ;
  69
  70 M: browser-gadget definitions-changed ( assoc browser -- )
  71     model>> [ value>> swap showing-definition? ] keep
  72     '[ _ notify-connections ] when ;
  73
  74 M: browser-gadget focusable-child* search-field>> ;
  75
  76 : (browser-window) ( topic -- )
  77     <browser-gadget> "Browser" open-status-window ;
  78
  79 : browser-window ( -- )
  80     "handbook" (browser-window) ;
  81
  82 \ browser-window H{ { +nullary+ t } } define-command
  83
  84 : com-browse ( link -- )
  85     [ browser-gadget? ] find-window
  86     [ [ raise-window ] [ gadget-child show-help ] bi ]
  87     [ (browser-window) ] if* ;
  88
  89 : show-browser ( -- ) "handbook" com-browse ;
  90
  91 \ show-browser H{ { +nullary+ t } } define-command
  92
  93 : com-back ( browser -- ) model>> go-back ;
  94
  95 : com-forward ( browser -- ) model>> go-forward ;
  96
  97 : com-documentation ( browser -- ) "handbook" swap show-help ;
  98
  99 : browser-help ( -- ) "ui-browser" com-browse ;
 100
 101 \ browser-help H{ { +nullary+ t } } define-command
 102
 103 browser-gadget "toolbar" f {
 104     { T{ key-down f { A+ } "LEFT" } com-back }
 105     { T{ key-down f { A+ } "RIGHT" } com-forward }
 106     { f com-documentation }
 107     { T{ key-down f f "F1" } browser-help }
 108 } define-command-map
 109
 110 : ?show-help ( link browser -- )
 111     over [ show-help ] [ 2drop ] if ;
 112
 113 : navigate ( browser quot -- )
 114     '[ control-value @ ] keep ?show-help ;
 115
 116 : com-up ( browser -- ) [ article-parent ] navigate ;
 117
 118 : com-prev ( browser -- ) [ prev-article ] navigate ;
 119
 120 : com-next ( browser -- ) [ next-article ] navigate ;
 121
 122 browser-gadget "navigation" "Commands for navigating in the article hierarchy" {
 123     { T{ key-down f { A+ } "u" } com-up }
 124     { T{ key-down f { A+ } "p" } com-prev }
 125     { T{ key-down f { A+ } "n" } com-next }
 126     { T{ key-down f { A+ } "k" } com-show-outgoing-links }
 127     { T{ key-down f { A+ } "K" } com-show-incoming-links }
 128 } define-command-map
 129
 130 browser-gadget "multi-touch" f {
 131     { left-action com-back }
 132     { right-action com-forward }
 133 } define-command-map
 134
 135 browser-gadget "scrolling"
 136 "The browser's scroller can be scrolled from the keyboard."
 137 {
 138     { T{ key-down f f "UP" } com-scroll-up }
 139     { T{ key-down f f "DOWN" } com-scroll-down }
 140     { T{ key-down f f "PAGE_UP" } com-page-up }
 141     { T{ key-down f f "PAGE_DOWN" } com-page-down }
 142 } define-command-map
 143
 144 MAIN: browser-window