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