Change tabular-output and smash-pane behavior to fix panes unit tests; re-organize...

[factor.git] / basis / ui / gadgets / panes / panes.factor

diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index c52c361b866523d0d8cea9fca5a6abdf609c197e..bf166f993ae460460aeeb81e0e1dc0a79bc191ef 100644 (file)
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -17,6 +17,12 @@ TUPLE: pane < track
 output current input last-line prototype scrolls?
 selection-color caret mark selecting? ;
 
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+<PRIVATE
+
 : clear-selection ( pane -- pane )
     f >>caret f >>mark ; inline
 
@@ -49,12 +55,6 @@ M: pane gadget-selection? pane-caret&mark and ;
 M: pane gadget-selection ( pane -- string/f )
     selected-children gadget-text ;
 
-: pane-clear ( pane -- )
-    clear-selection
-    [ output>> clear-incremental ]
-    [ current>> clear-gadget ]
-    bi ;
-
 : init-prototype ( pane -- pane )
     <shelf> +baseline+ >>align >>prototype ; inline
 
@@ -70,17 +70,6 @@ M: pane gadget-selection ( pane -- string/f )
     [ >>last-line ] [ 1 track-add ] bi
     dup prepare-last-line ; inline
 
-: new-pane ( input class -- pane )
-    [ vertical ] dip new-track
-        swap >>input
-        pane-theme
-        init-prototype
-        init-output
-        init-current
-        init-last-line ; inline
-
-: <pane> ( -- pane ) f pane new-pane ;
-
 GENERIC: draw-selection ( loc obj -- )
 
 : if-fits ( rect quot -- )
@@ -112,10 +101,6 @@ M: pane draw-gadget*
 : scroll-pane ( pane -- )
     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
 
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
 : smash-line ( current -- gadget )
     dup children>> {
         { [ dup empty? ] [ 2drop "" <label> ] }
@@ -123,14 +108,18 @@ C: <pane-stream> pane-stream
         [ drop ]
     } cond ;
 
-: smash-pane ( pane -- gadget ) output>> smash-line ;
-
 : pane-nl ( pane -- )
     [
         [ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
         add-incremental
     ] [ next-line ] bi ;
 
+: ?pane-nl ( pane -- )
+    [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
+    [ pane-nl ] bi ;
+
+: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
+
 : pane-write ( seq pane -- )
     [ pane-nl ] [ current>> stream-write ]
     bi-curry interleave ;
@@ -139,6 +128,41 @@ C: <pane-stream> pane-stream
     [ nip pane-nl ] [ current>> stream-format ]
     bi-curry bi-curry interleave ;
 
+: do-pane-stream ( pane-stream quot -- )
+    [ pane>> ] dip keep scroll-pane ; inline
+
+M: pane-stream stream-nl
+    [ pane-nl ] do-pane-stream ;
+
+M: pane-stream stream-write1
+    [ current>> stream-write1 ] do-pane-stream ;
+
+M: pane-stream stream-write
+    [ [ string-lines ] dip pane-write ] do-pane-stream ;
+
+M: pane-stream stream-format
+    [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
+
+M: pane-stream dispose drop ;
+
+M: pane-stream stream-flush drop ;
+
+M: pane-stream make-span-stream
+    swap <style-stream> <ignore-close-stream> ;
+
+PRIVATE>
+
+: new-pane ( input class -- pane )
+    [ vertical ] dip new-track
+        swap >>input
+        pane-theme
+        init-prototype
+        init-output
+        init-current
+        init-last-line ; inline
+
+: <pane> ( -- pane ) f pane new-pane ;
+
 GENERIC: write-gadget ( gadget stream -- )
 
 M: pane-stream write-gadget ( gadget pane-stream -- )
@@ -153,17 +177,18 @@ M: style-stream write-gadget
 : gadget. ( gadget -- )
     output-stream get print-gadget ;
 
-: ?nl ( stream -- )
-    dup pane>> current>> children>> empty?
-    [ dup stream-nl ] unless drop ;
+: pane-clear ( pane -- )
+    clear-selection
+    [ output>> clear-incremental ]
+    [ current>> clear-gadget ]
+    bi ;
 
 : with-pane ( pane quot -- )
-    over scroll>top
-    over pane-clear [ <pane-stream> ] dip
-    over [ with-output-stream* ] dip ?nl ; inline
+    [ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
+    with-output-stream* ; inline
 
 : make-pane ( quot -- gadget )
-    <pane> [ swap with-pane ] keep smash-pane ; inline
+    [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
 
 TUPLE: pane-control < pane quot ;
 
@@ -176,29 +201,8 @@ M: pane-control model-changed ( model pane-control -- )
         swap >>quot
         swap >>model ;
 
-: do-pane-stream ( pane-stream quot -- )
-    [ pane>> ] dip keep scroll-pane ; inline
-
-M: pane-stream stream-nl
-    [ pane-nl ] do-pane-stream ;
-
-M: pane-stream stream-write1
-    [ current>> stream-write1 ] do-pane-stream ;
-
-M: pane-stream stream-write
-    [ [ string-lines ] dip pane-write ] do-pane-stream ;
-
-M: pane-stream stream-format
-    [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
-
-M: pane-stream dispose drop ;
-
-M: pane-stream stream-flush drop ;
-
-M: pane-stream make-span-stream
-    swap <style-stream> <ignore-close-stream> ;
-
 ! Character styles
+<PRIVATE
 
 MEMO: specified-font ( assoc -- font )
     #! We memoize here to avoid creating lots of duplicate font objects.
@@ -279,10 +283,7 @@ TUPLE: nested-pane-stream < pane-stream style parent ;
     inline
 
 : unnest-pane-stream ( stream -- child parent )
-    dup ?nl
-    dup style>>
-    over pane>> smash-pane style-pane
-    swap parent>> ;
+    [ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
 
 TUPLE: pane-block-stream < nested-pane-stream ;
 
@@ -309,7 +310,7 @@ M: pane-stream make-block-stream
 
 TUPLE: pane-cell-stream < nested-pane-stream ;
 
-M: pane-cell-stream dispose ?nl ;
+M: pane-cell-stream dispose drop ;
 
 M: pane-stream make-cell-stream
     pane-cell-stream new-nested-pane-stream ;
@@ -318,7 +319,7 @@ M: pane-stream stream-write-table
     [
         swap [ [ pane>> smash-pane ] map ] map
         styled-grid
-    ] dip print-gadget ;
+    ] dip write-gadget ;
 
 ! Stream utilities
 M: pack dispose drop ;
@@ -433,6 +434,8 @@ M: f sloppy-pick-up*
 
 : pane-menu ( pane -- ) { com-copy } show-commands-menu ;
 
+PRIVATE>
+
 pane H{
     { T{ button-down } [ begin-selection ] }
     { T{ button-down f { S+ } 1 } [ select-to-caret ] }