diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index e242b743f8..0c6e1fe05a 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,23 +1,33 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger help help.topics help.crossref help.home kernel -models compiler.units assocs words vocabs accessors fry -combinators.short-circuit namespaces sequences models -models.history help.apropos combinators ui.commands ui.gadgets -ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks -ui.gestures ui.gadgets.buttons ui.gadgets.packs -ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar -ui.gadgets.glass ui.gadgets.borders ui.tools.common -ui.tools.browser.popups ui ; +USING: debugger help help.topics help.crossref help.home kernel models +compiler.units assocs words vocabs accessors fry arrays +combinators.short-circuit namespaces sequences models help.apropos +combinators ui ui.commands ui.gadgets ui.gadgets.panes +ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons +ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels +ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports +ui.tools.common ui.tools.browser.popups ui.tools.browser.history ; IN: ui.tools.browser -TUPLE: browser-gadget < tool pane scroller search-field popup ; +TUPLE: browser-gadget < tool history pane scroller search-field popup ; { 650 400 } browser-gadget set-tool-dim +M: browser-gadget history-value + [ control-value ] [ scroller>> scroll-position ] + bi 2array ; + +M: browser-gadget set-history-value + [ first2 ] dip + [ set-control-value ] [ scroller>> set-scroll-position ] + bi-curry bi* ; + : show-help ( link browser-gadget -- ) - [ >link ] [ model>> ] bi* - [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ; + [ >link ] dip + [ [ add-recent ] [ history>> add-history ] bi* ] + [ model>> set-model ] + 2bi ; : ( browser-gadget -- gadget ) model>> [ '[ _ print-topic ] try ] ; @@ -41,7 +51,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ; : ( link -- gadget ) vertical browser-gadget new-track 1 >>fill - swap >link >>model + swap >link >>model + dup >>history dup >>search-field dup { 3 3 } { 1 0 } >>fill f track-add dup >>pane @@ -93,9 +104,9 @@ M: browser-gadget focusable-child* search-field>> ; \ show-browser H{ { +nullary+ t } } define-command -: com-back ( browser -- ) model>> go-back ; +: com-back ( browser -- ) history>> go-back ; -: com-forward ( browser -- ) model>> go-forward ; +: com-forward ( browser -- ) history>> go-forward ; : com-home ( browser -- ) "help.home" swap show-help ; diff --git a/basis/ui/tools/browser/history/authors.txt b/basis/ui/tools/browser/history/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/browser/history/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor new file mode 100644 index 0000000000..20b16f450a --- /dev/null +++ b/basis/ui/tools/browser/history/history-tests.factor @@ -0,0 +1,36 @@ +USING: namespaces ui.tools.browser.history sequences tools.test ; +IN: ui.tools.browser.history.tests + +f "history" set + +"history" get add-history + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +"history" get 3 >>value drop + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +"history" get 4 >>value drop + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get go-back + +[ 3 ] [ "history" get value>> ] unit-test + +[ t ] [ "history" get back>> empty? ] unit-test +[ f ] [ "history" get forward>> empty? ] unit-test + +"history" get go-forward + +[ 4 ] [ "history" get value>> ] unit-test + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + diff --git a/basis/ui/tools/browser/history/history.factor b/basis/ui/tools/browser/history/history.factor new file mode 100644 index 0000000000..f80189c783 --- /dev/null +++ b/basis/ui/tools/browser/history/history.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences locals ; +IN: ui.tools.browser.history + +TUPLE: history owner back forward ; + +: ( owner -- history ) + V{ } clone V{ } clone history boa ; + +GENERIC: history-value ( object -- value ) + +GENERIC: set-history-value ( value object -- ) + +: (add-history) ( history to -- ) + swap owner>> history-value dup [ swap push ] [ 2drop ] if ; + +:: go-back/forward ( history to from -- ) + from empty? [ + history to (add-history) + from pop history owner>> set-history-value + ] unless ; + +: go-back ( history -- ) + dup [ forward>> ] [ back>> ] bi go-back/forward ; + +: go-forward ( history -- ) + dup [ back>> ] [ forward>> ] bi go-back/forward ; + +: add-history ( history -- ) + dup forward>> delete-all + dup back>> (add-history) ; \ No newline at end of file