2008-01-09 04:52:08 -05:00
|
|
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
|
USING: debugger ui.tools.workspace help help.topics kernel
|
|
|
|
|
models ui.commands ui.gadgets ui.gadgets.panes
|
|
|
|
|
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
|
2008-06-08 16:32:55 -04:00
|
|
|
ui.gadgets.buttons compiler.units assocs words vocabs
|
|
|
|
|
accessors ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: ui.tools.browser
|
|
|
|
|
|
|
|
|
|
TUPLE: browser-gadget pane history ;
|
|
|
|
|
|
|
|
|
|
: show-help ( link help -- )
|
2008-06-08 16:32:55 -04:00
|
|
|
dup history>> add-history
|
|
|
|
|
>r >link r> history>> set-model ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
: <help-pane> ( browser-gadget -- gadget )
|
2008-06-11 03:58:38 -04:00
|
|
|
history>> [ [ help ] curry try ] <pane-control> ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
: init-history ( browser-gadget -- )
|
2008-06-08 16:32:55 -04:00
|
|
|
"handbook" >link <history> >>history drop ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
: <browser-gadget> ( -- gadget )
|
2008-04-13 16:06:27 -04:00
|
|
|
browser-gadget new
|
2007-09-20 18:09:08 -04:00
|
|
|
dup init-history [
|
|
|
|
|
toolbar,
|
|
|
|
|
g <help-pane> g-> set-browser-gadget-pane
|
|
|
|
|
<scroller> 1 track,
|
|
|
|
|
] { 0 1 } build-track ;
|
|
|
|
|
|
|
|
|
|
M: browser-gadget call-tool* show-help ;
|
|
|
|
|
|
|
|
|
|
M: browser-gadget tool-scroller
|
2008-06-08 16:32:55 -04:00
|
|
|
pane>> find-scroller ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-01-09 04:52:08 -05:00
|
|
|
M: browser-gadget graft*
|
|
|
|
|
dup add-definition-observer
|
|
|
|
|
delegate graft* ;
|
|
|
|
|
|
|
|
|
|
M: browser-gadget ungraft*
|
|
|
|
|
dup delegate ungraft*
|
|
|
|
|
remove-definition-observer ;
|
|
|
|
|
|
|
|
|
|
: showing-definition? ( defspec assoc -- ? )
|
2008-01-09 13:41:58 -05:00
|
|
|
[ key? ] 2keep
|
|
|
|
|
[ >r dup word-link? [ link-name ] when r> key? ] 2keep
|
|
|
|
|
>r dup vocab-link? [ vocab ] when r> key?
|
|
|
|
|
or or ;
|
2008-01-09 04:52:08 -05:00
|
|
|
|
|
|
|
|
M: browser-gadget definitions-changed ( assoc browser -- )
|
2008-06-08 16:32:55 -04:00
|
|
|
history>>
|
2008-01-09 04:52:08 -05:00
|
|
|
dup model-value rot showing-definition?
|
|
|
|
|
[ notify-connections ] [ drop ] if ;
|
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: help-action ( browser-gadget -- link )
|
2008-06-08 16:32:55 -04:00
|
|
|
history>> model-value >link ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-06-08 16:32:55 -04:00
|
|
|
: com-follow ( link -- ) browser-gadget call-tool ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-06-08 16:32:55 -04:00
|
|
|
: com-back ( browser -- ) history>> go-back ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-06-08 16:32:55 -04:00
|
|
|
: com-forward ( browser -- ) history>> go-forward ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-06-08 16:32:55 -04:00
|
|
|
: com-documentation ( browser -- ) "handbook" swap show-help ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-06-08 16:32:55 -04:00
|
|
|
: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-06-08 16:32:55 -04:00
|
|
|
: browser-help ( -- ) "ui-browser" help-window ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
\ browser-help H{ { +nullary+ t } } define-command
|
|
|
|
|
|
|
|
|
|
browser-gadget "toolbar" f {
|
|
|
|
|
{ T{ key-down f { A+ } "b" } com-back }
|
|
|
|
|
{ T{ key-down f { A+ } "f" } com-forward }
|
|
|
|
|
{ T{ key-down f { A+ } "h" } com-documentation }
|
|
|
|
|
{ T{ key-down f { A+ } "v" } com-vocabularies }
|
|
|
|
|
{ T{ key-down f f "F1" } browser-help }
|
|
|
|
|
} define-command-map
|
2008-04-11 23:33:01 -04:00
|
|
|
|
|
|
|
|
browser-gadget "multi-touch" f {
|
|
|
|
|
{ T{ left-action } com-back }
|
|
|
|
|
{ T{ right-action } com-forward }
|
|
|
|
|
} define-command-map
|
