Browser tool now saves scroll bar position in history

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
+USING: debugger help help.topics help.crossref help.home kernel models
-models compiler.units assocs words vocabs accessors fry
+compiler.units assocs words vocabs accessors fry arrays
-combinators.short-circuit namespaces sequences models
+combinators.short-circuit namespaces sequences models help.apropos
-models.history help.apropos combinators ui.commands ui.gadgets
+combinators ui ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
-ui.gestures ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
+ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports
-ui.gadgets.glass ui.gadgets.borders ui.tools.common
+ui.tools.common ui.tools.browser.popups ui.tools.browser.history ;
-ui.tools.browser.popups ui ;
 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*
+    [ >link ] dip
-    [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ;
+    [ [ add-recent ] [ history>> add-history ] bi* ]
+    [ model>> set-model ]
+    2bi ;
 
 : <help-pane> ( browser-gadget -- gadget )
     model>> [ '[ _ print-topic ] try ] <pane-control> ;
@@ -41,7 +51,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ;
 : <browser-gadget> ( link -- gadget )
     vertical browser-gadget new-track
         1 >>fill
-        swap >link <history> >>model
+        swap >link <model> >>model
+        dup <history> >>history
         dup <search-field> >>search-field
         dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
         dup <help-pane> >>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 ;
 

basis/ui/tools/browser/history/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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> "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
+

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 ;
+
+: <history> ( 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) ;