Pane, track, toolbar fixes

TODO.FACTOR.txt

@@ -10,7 +10,6 @@
 - slider needs to be modelized
 - some way of intercepting all gestures
 - better help result ranking
-- track add/remove weirdness
 - minibuffer should show a title
 
 + ui:

library/ui/gadgets/panes.factor

@@ -25,6 +25,13 @@ C: pane ( -- pane )
     <pile> <incremental> over add-output
     dup prepare-line ;
 
+! Panes are streams.
+
+: scroll-pane ( pane -- )
+    dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
+
+TUPLE: pane-stream pane ;
+
 : prepare-print ( current -- gadget )
     #! Optimization: if line has 1 child, add the child.
     dup gadget-children {
@@ -33,30 +40,24 @@ C: pane ( -- pane )
         { [ t ] [ drop ] }
     } cond ;
 
+: pane-terpri ( pane -- )
+    dup pane-current dup unparent prepare-print
+    over pane-output add-incremental
+    prepare-line ;
+
 : pane-write ( pane seq -- )
     [ over pane-current stream-write ]
-    [ dup stream-terpri ] interleave drop ;
+    [ dup pane-terpri ] interleave drop ;
 
 : pane-format ( style pane seq -- )
     [ pick pick pane-current stream-format ]
-    [ dup stream-terpri ] interleave 2drop ;
-
-! Panes are streams.
-
-: scroll-pane ( pane -- )
-    dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
-
-TUPLE: pane-stream pane ;
+    [ dup pane-terpri ] interleave 2drop ;
 
 : do-pane-stream ( pane-stream quot -- )
     >r pane-stream-pane r> over slip scroll-pane ; inline
 
 M: pane-stream stream-terpri
-    [
-        dup pane-current dup unparent prepare-print
-        over pane-output add-incremental
-        prepare-line
-    ] do-pane-stream ;
+    [ pane-terpri ] do-pane-stream ;
 
 M: pane-stream stream-write1
     [ pane-current stream-write1 ] do-pane-stream ;

library/ui/gadgets/tracks.factor

@@ -116,15 +116,19 @@ C: divider ( -- divider )
     dup add-divider [ add-gadget ] keep
     dup track-sizes track-add-size swap set-track-sizes ;
 
-: track-remove@ ( n track -- )
-    #! Remove the divider if this is not the last child.
-    2dup nth-gadget unparent
-    dup gadget-children empty? [
-        2dup gadget-children length = [ >r 1- r> ] when
-        2dup nth-gadget unparent
-    ] unless
+: remove-divider ( n track -- )
+    2dup gadget-children length = [ >r 1- r> ] when
+    nth-gadget unparent ;
+
+: track-remove-size ( n track -- )
     [ >r 2 /i r> track-sizes remove-nth normalize-sizes ] keep
-    [ set-track-sizes ] keep relayout-1 ;
+    set-track-sizes ;
+
+: track-remove@ ( n track -- )
+    2dup nth-gadget unparent
+    dup gadget-children empty? [ 2dup remove-divider ] unless
+    [ track-remove-size ] keep
+    relayout-1 ;
 
 : track-remove ( gadget track -- )
     [ gadget-children index ] keep track-remove@ ;

library/ui/load.factor

@@ -56,4 +56,5 @@ PROVIDE: library/ui {
     "test/commands.factor"
     "test/panes.factor"
     "test/editor.factor"
+    "test/tracks.factor"
 } ;

library/ui/test/tracks.factor

@@ -0,0 +1,48 @@
+IN: temporary
+USING: gadgets-tracks gadgets test kernel namespaces math
+sequences ;
+
+[ { 1/3 1/2 1/6 } ] [
+    { 1/3 1/2 1/6 } track-add-size 1 head* normalize-sizes
+] unit-test
+
+{
+    {
+        [ <gadget> { 100 200 } over set-rect-dim ]
+        f
+        f
+        1/2
+    }
+    {
+        [ <gadget> { 100 100 } over set-rect-dim ]
+        f
+        f
+        1/4
+    }
+    {
+        [ <gadget> { 100 100 } over set-rect-dim ]
+        f
+        f
+        1/4
+    }
+} { 0 1 } make-track "track" set
+
+"track" get dup prefer layout
+
+[ { 100 416 } ] [ "track" get rect-dim ] unit-test
+
+[ V{ { 100 200 } { 100 8 } { 100 100 } { 100 8 } { 100 100 } } ]
+[ "track" get gadget-children [ rect-dim ] map ] unit-test
+
+[ { 1/2 1/4 1/4 } ] [ "track" get track-sizes ] unit-test
+
+<gadget> { 70 70 } over set-rect-dim "track" get track-add
+"track" get layout
+[ { 3/8 3/16 3/16 1/4 } ] [ "track" get track-sizes ] unit-test
+
+"track" get [ gadget-children length 1- ] keep track-remove@
+"track" get layout
+[ { 1/2 1/4 1/4 } ] [ "track" get track-sizes ] unit-test
+
+[ V{ { 100 200 } { 100 8 } { 100 100 } { 100 8 } { 100 100 } } ]
+[ "track" get gadget-children [ rect-dim ] map ] unit-test

library/ui/tools/browser.factor

@@ -104,7 +104,7 @@ M: browser focusable-child* browser-search ;
 : clear-browser ( browser -- )
     browser-definitions close-definitions ;
 
-browser "Browser commands" {
+browser "Toolbar" {
     { "Clear" T{ key-down f f "CLEAR" } [ clear-browser ] }
 } define-commands
 

library/ui/tools/dataflow.factor

@@ -188,7 +188,7 @@ DEFER: (compute-heights)
 ! The UI tool
 TUPLE: dataflow-gadget history search ;
 
-dataflow-gadget "History commands" {
+dataflow-gadget "Toolbar" {
     { "Back" T{ key-down f { C+ } "b" } [ dataflow-gadget-history go-back ] }
     { "Forward" T{ key-down f { C+ } "f" } [ dataflow-gadget-history go-forward ] }
 } define-commands

library/ui/tools/help.factor

@@ -37,8 +37,12 @@ M: help-gadget tool-help drop "ui-help" ;
 : help-action ( help-gadget -- link )
     help-gadget-history model-value >link ;
 
-help-gadget "History commands" {
+help-gadget "Toolbar" {
     { "Back" T{ key-down f { C+ } "b" } [ help-gadget-history go-back ] }
     { "Forward" T{ key-down f { C+ } "f" } [ help-gadget-history go-forward ] }
     { "Home" T{ key-down f { C+ } "h" } [ go-home ] }
-} define-commands
+}
+link class-operations [ help-action ] modify-operations
+[ command-name "Follow" = not ] subset
+append
+define-commands

library/ui/tools/listener.factor

@@ -135,9 +135,8 @@ M: listener-gadget tool-help
     [ [ hash-values [ dup set ] each ] each ] make-hash
     hash-values natural-sort ;
 
-listener-gadget "Listener commands" {
+listener-gadget "Toolbar" {
     { "Restart" T{ key-down f { C+ } "r" } [ start-listener ] }
-    { "Send EOF" T{ key-down f { C+ } "d" } [ listener-eof ] }
     {
         "History"
         T{ key-down f { C+ } "h" }
@@ -153,6 +152,10 @@ listener-gadget "Listener commands" {
         T{ key-down f { C+ } "CLEAR" }
         [ clear-listener-stack ]
     }
+    { "Send EOF" T{ key-down f { C+ } "d" } [ listener-eof ] }
+} define-commands
+
+listener-gadget "Listener commands" {
     {
         "Complete word (used vocabs)"
         T{ key-down f f "TAB" }

library/ui/tools/messages.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler kernel gadgets-tracks gadgets-scrolling
 gadgets-workspace gadgets-panes gadgets-presentations
-gadgets-buttons inference errors io math gadgets namespaces ;
+gadgets-buttons inference errors io math gadgets namespaces
+generic ;
 IN: gadgets-messages
 
 TUPLE: messages counter errors errors# warnings warnings# ;
@@ -22,13 +23,13 @@ M: messages compile-begins
 : messages-warnings+
     dup messages-warnings# 1+ swap set-messages-warnings# ;
 
+M: object inference-error-major? drop t ;
+
 M: messages compile-error
-    over inference-error?
-    [ over inference-error-major? ]
-    [ t ] if
+    over inference-error-major?
     [ dup messages-errors+ messages-errors ]
     [ dup messages-warnings+ messages-warnings ] if
-    [ error. ] with-stream ;
+    <pane-stream> [ error. ] with-stream ;
 
 : <messages-button> ( -- gadget )
     "Compiler messages"

library/ui/tools/operations.factor

@@ -211,9 +211,3 @@ interactor "Quotation commands"
 quotation class-operations
 [ quot-action ] modify-listener-operations
 define-commands
-
-! Help commands
-help-gadget "Link commands"
-link class-operations [ help-action ] modify-operations
-[ command-name "Follow" = not ] subset
-define-commands

library/ui/tools/walker.factor

@@ -77,7 +77,7 @@ M: walker-gadget tool-help drop "ui-walker" ;
     dup [ step-all ] walker-command reset-walker
     find-workspace listener-gadget select-tool ;
 
-walker-gadget "Walker commands" {
+walker-gadget "Toolbar" {
     { "Step" T{ key-down f f "s" } [ walker-step ] }
     { "Step in" T{ key-down f f "i" } [ walker-step-in ] }
     { "Step out" T{ key-down f f "o" } [ walker-step-out ] }

library/ui/ui.factor

@@ -120,7 +120,7 @@ C: titled-gadget ( gadget title -- )
     windows get [ empty? not ] [ f ] if* ;
 
 : <toolbar> ( target classes -- toolbar )
-    [ [ commands hash-values [ % ] each ] each ] { } make
+    [ commands "Toolbar" swap hash ] map concat
     [ <command-presentation> ] map-with
     make-shelf ;