steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Help viewer and model updates

darcs
slava 2006-07-01 20:07:10 +00:00
parent ee3acaabc1
commit b4359d8373
5 changed files with 165 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
library/test/gadgets/models.factor Normal file
View File

@ -0,0 +1,69 @@
IN: temporary
USING: arrays kernel models namespaces sequences test ;
TUPLE: model-tester hit? ;
C: model-tester ;
M: model-tester model-changed t swap set-model-tester-hit? ;
[ T{ model-tester f f } ]
[
T{ model-tester f f } 3 <model> 2dup add-connection
3 swap set-model
] unit-test
[ T{ model-tester f t } ]
[
T{ model-tester f f } 3 <model> 2dup add-connection
5 swap set-model
] unit-test
3 <model> "model-a" set
4 <model> "model-b" set
"model-a" get "model-b" get 2array <compose> "model-c" set
[ { 3 4 } ] [ "model-c" get model-value ] unit-test
T{ model-tester f f } dup "tester" set
[ T{ model-tester f t } { 6 4 } ]
[
"tester" get "model-c" get add-connection
6 "model-a" get set-model
"tester" get
"model-c" get model-value
] unit-test
<history> "history" set
"history" get add-history
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get add-history
3 "history" get set-model
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get add-history
4 "history" get set-model
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get go-back
[ 3 ] [ "history" get model-value ] unit-test
[ t ] [ "history" get history-back empty? ] unit-test
[ f ] [ "history" get history-forward empty? ] unit-test
"history" get go-forward
[ 4 ] [ "history" get model-value ] unit-test
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test

76
library/test/test.factor
View File

@ -68,21 +68,51 @@ SYMBOL: failures
: tests
{
"alien"
"annotate"
"binary"
"collections/hashtables"
"collections/namespaces"
"collections/queues"
"collections/sbuf"
"collections/sequences"
"collections/strings"
"collections/vectors"
"combinators"
"continuations" "errors"
"collections/hashtables" "collections/sbuf"
"collections/strings" "collections/namespaces"
"collections/vectors" "collections/sequences"
"collections/queues" "generic" "tuple" "parser"
"parse-number" "init" "io/io" "io/nested-style"
"words" "prettyprint" "random" "stream" "math/bitops"
"math/math-combinators" "math/rational" "math/float"
"math/complex" "math/irrational"
"math/integer" "math/random" "threads" "parsing-word"
"inference" "interpreter" "alien"
"gadgets/line-editor" "gadgets/rectangles" "memory"
"redefine" "annotate" "binary" "inspector"
"kernel" "help/porter-stemmer" "help/topics"
"continuations"
"errors"
"gadgets/line-editor"
"gadgets/models"
"gadgets/rectangles"
"generic"
"help/porter-stemmer"
"help/topics"
"inference"
"init"
"inspector"
"interpreter"
"io/io"
"io/nested-style"
"kernel"
"math/bitops"
"math/complex"
"math/float"
"math/integer"
"math/irrational"
"math/math-combinators"
"math/random"
"math/rational"
"memory"
"parse-number"
"parser"
"parsing-word"
"prettyprint"
"random"
"redefine"
"stream"
"threads"
"tuple"
"words"
} run-tests ;
: benchmarks
@ -98,10 +128,16 @@ SYMBOL: failures
: compiler-tests
{
"io/buffer"
"compiler/simple" "compiler/templates"
"compiler/stack" "compiler/ifte"
"compiler/generic" "compiler/bail-out"
"compiler/intrinsics" "compiler/float"
"compiler/identities" "compiler/optimizer"
"compiler/alien" "compiler/callbacks"
"compiler/simple"
"compiler/templates"
"compiler/stack"
"compiler/ifte"
"compiler/generic"
"compiler/bail-out"
"compiler/intrinsics"
"compiler/float"
"compiler/identities"
"compiler/optimizer"
"compiler/alien"
"compiler/callbacks"
} run-tests ;

2
library/ui/hierarchy.factor
View File

@ -11,7 +11,7 @@ M: gadget graft* drop ;
: graft ( gadget -- )
t over set-gadget-grafted?
dup graft*
dup [ graft ] each-child ;
[ graft ] each-child ;
GENERIC: ungraft* ( gadget -- )

27
library/ui/models.factor
View File

@ -28,7 +28,7 @@ DEFER: remove-connection
: deactivate-model ( model -- )
dup model-dependencies [ remove-connection ] each-with ;
GENERIC: model-changed ( model -- )
GENERIC: model-changed ( observer -- )
: add-connection ( obj model -- )
dup model-connections empty? [ dup activate-model ] when
@ -76,3 +76,28 @@ C: compose ( models -- compose )
M: compose model-changed ( compose -- )
dup model-dependencies [ model-value ] map
swap set-model ;
TUPLE: history back forward ;
C: history ( -- history )
dup delegate>model
V{ } clone over set-history-back
V{ } clone over set-history-forward ;
: (add-history) ( history vector -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
[ 3drop ]
[ >r dupd (add-history) r> pop swap set-model ] if ;
: go-back ( history -- )
dup history-forward over history-back go-back/forward ;
: go-forward ( history -- )
dup history-back over history-forward go-back/forward ;
: add-history ( history -- )
0 over history-forward set-length
dup history-back (add-history) ;

39
library/ui/tools/help.factor
View File

@ -2,53 +2,40 @@
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-help
USING: gadgets gadgets-buttons gadgets-frames gadgets-panes
gadgets-presentations gadgets-scrolling gadgets-search
gadgets-tiles gadgets-tracks help io kernel models namespaces
sequences words ;
gadgets-presentations gadgets-scrolling help kernel models
namespaces sequences ;
TUPLE: help-gadget showing history pane ;
TUPLE: help-gadget history ;
: find-help-gadget [ help-gadget? ] find-parent ;
: go-back ( help -- )
dup help-gadget-history dup empty? [
2drop
] [
pop swap help-gadget-showing set-model
] if ;
: add-history ( help -- )
dup help-gadget-showing model-value dup [
swap help-gadget-history push
] [
2drop
] if ;
: show-help ( link help -- )
dup add-history
[ help-gadget-showing set-model ] keep
dup help-gadget-history add-history
[ help-gadget-history set-model ] keep
dup update-title ;
: go-home ( help -- ) "handbook" swap show-help ;
: history-action find-help-gadget help-gadget-history ;
: <help-toolbar> ( -- gadget )
[
"Back" [ find-help-gadget go-back ] <bevel-button> ,
"Home" [ find-help-gadget go-home ] <bevel-button> ,
"Back" [ history-action go-back ] <bevel-button> ,
"Forward" [ history-action go-forward ] <bevel-button> ,
"Home" [ history-action go-home ] <bevel-button> ,
] make-toolbar ;
: <help-pane> ( -- gadget )
gadget get help-gadget-showing [ help ] <pane-control> ;
gadget get help-gadget-history [ help ] <pane-control> ;
C: help-gadget ( -- gadget )
V{ } over set-help-gadget-history
f <model> over set-help-gadget-showing {
<history> over set-help-gadget-history {
{ [ <help-toolbar> ] f f @top }
{ [ <help-pane> <scroller> ] f f @center }
} make-frame* ;
M: help-gadget gadget-title
"Help - " swap help-gadget-showing model-value
"Help - " swap help-gadget-history model-value
article-title append ;
: help-tool