ui.gadgets.panes: change approach to nested-pane-stream.

basis/ui/gadgets/panes/panes.factor

@@ -2,14 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs classes combinators destructors
 documents.private fonts fry io io.styles kernel locals math
-math.rectangles math.vectors models namespaces sequences sorting
+math.rectangles math.vectors models namespaces sequences sets
-splitting strings ui.baseline-alignment ui.clipboards ui.gadgets
+sorting splitting strings ui.baseline-alignment ui.clipboards
-ui.gadgets.borders ui.gadgets.grid-lines ui.gadgets.grids
+ui.gadgets ui.gadgets.borders ui.gadgets.grid-lines
-ui.gadgets.icons ui.gadgets.incremental ui.gadgets.labels
+ui.gadgets.grids ui.gadgets.icons ui.gadgets.incremental
-ui.gadgets.menus ui.gadgets.packs ui.gadgets.paragraphs
+ui.gadgets.labels ui.gadgets.menus ui.gadgets.packs
-ui.gadgets.presentations ui.gadgets.private ui.gadgets.scrollers
+ui.gadgets.paragraphs ui.gadgets.presentations
-ui.gadgets.tracks ui.gestures ui.images ui.pens.solid ui.render
+ui.gadgets.private ui.gadgets.scrollers ui.gadgets.tracks
-ui.theme ui.traverse unicode ;
+ui.gestures ui.images ui.pens.solid ui.render ui.theme
+ui.traverse unicode ;
 FROM: io.styles => foreground background ;
 FROM: ui.gadgets.wrappers => <wrapper> ;
 IN: ui.gadgets.panes
@@ -18,13 +19,16 @@ TUPLE: pane < track
     output current input last-line prototype scrolls?
     selection-color caret mark selecting? ;
 
-TUPLE: pane-stream pane ;
+TUPLE: pane-stream pane parent ;
 INSTANCE: pane-stream output-stream
 
-C: <pane-stream> pane-stream
+: <pane-stream> ( pane -- pane-stream )
+    f pane-stream boa ;
 
 M: pane-stream stream-element-type drop +character+ ;
 
+DEFER: write-gadget
+
 <PRIVATE
 
 : clear-selection ( pane -- pane )
@@ -56,8 +60,7 @@ M: pane-stream stream-element-type drop +character+ ;
 
 M: pane gadget-selection? pane-caret&mark and ;
 
-M: pane gadget-selection ( pane -- string/f )
+M: pane gadget-selection selected-subtree gadget-text ;
-    selected-subtree gadget-text ;
 
 : init-prototype ( pane -- pane )
     <shelf> +baseline+ >>align >>prototype ; inline
@@ -97,21 +100,23 @@ M: pane selected-children
         add-incremental
     ] [ next-line ] bi ;
 
-: smash-pane ( pane -- gadget )
+GENERIC: smash-pane ( pane -- gadget )
+
+M: pane smash-pane
     [ pane-nl ] [ output>> smash-line ] bi ;
 
-GENERIC: pane-write ( str gadget -- )
+GENERIC: pane-line ( str style gadget -- )
-GENERIC: pane-write1 ( char gadget -- )
-GENERIC: pane-format ( str style gadget -- )
 
-M: pane pane-write
+: pane-format ( lines style pane -- )
-    [ pane-nl ] [ current>> pane-write ]
+    [ nip pane-nl ] [ current>> pane-line ]
-    bi-curry interleave ;
-
-M: pane pane-format
-    [ nip pane-nl ] [ current>> pane-format ]
     bi-curry bi-curry interleave ;
 
+: pane-write ( lines pane -- )
+    H{ } swap pane-format ;
+
+: pane-write1 ( char pane -- )
+    [ 1string H{ } ] dip current>> pane-line ;
+
 : do-pane-stream ( pane-stream quot -- )
     [ pane>> ] dip keep scroll-pane ; inline
 
@@ -119,7 +124,7 @@ M: pane-stream stream-nl
     [ pane-nl ] do-pane-stream ;
 
 M: pane-stream stream-write1
-    [ current>> pane-write1 ] do-pane-stream ;
+    [ pane-write1 ] do-pane-stream ;
 
 : split-pane ( str quot: ( str -- ) -- )
     '[
@@ -134,7 +139,12 @@ M: pane-stream stream-write
 M: pane-stream stream-format
     [ '[ _ _ pane-format ] split-pane ] do-pane-stream ;
 
-M: pane-stream dispose drop ;
+M: pane-stream dispose
+    dup parent>> [
+        [ pane>> smash-pane ] dip write-gadget
+    ] [ drop ] if* ;
+
+! M: pane-stream dispose drop ;
 
 M: pane-stream stream-flush drop ;
 
@@ -167,12 +177,9 @@ M: object write-gadget
 M: filter-writer write-gadget
     stream>> write-gadget ;
 
-M: pane-stream write-gadget ( gadget pane-stream -- )
+M: pane-stream write-gadget
     pane>> current>> swap add-gadget drop ;
 
-M: style-stream write-gadget
-    stream>> write-gadget ;
-
 : print-gadget ( gadget stream -- )
     [ write-gadget ] [ nip stream-nl ] 2bi ;
 
@@ -190,7 +197,7 @@ M: style-stream write-gadget
     with-output-stream* ; inline
 
 : make-pane ( quot -- gadget )
-    [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
+    [ <pane> ] dip '[ _ with-pane ] keep smash-pane ; inline
 
 TUPLE: pane-control < pane quot ;
 
@@ -243,16 +250,13 @@ MEMO:: specified-font ( name style size foreground background -- font )
 : apply-background-style ( style gadget -- style gadget )
     background [ <solid> >>interior ] apply-style ;
 
-: style-label ( style gadget -- gadget )
+: apply-character-style ( style gadget -- gadget )
     apply-font-style
     apply-background-style
-    apply-presentation-style
     apply-image-style
+    apply-presentation-style
     nip ; inline
 
-: <styled-label> ( style text -- gadget )
-    <label> style-label ;
-
 ! Paragraph styles
 
 : apply-wrap-style ( style pane -- style pane )
@@ -270,28 +274,39 @@ MEMO:: specified-font ( name style size foreground background -- font )
 : apply-inset-style ( style gadget -- style gadget )
     inset [ <border> ] apply-style ;
 
-: style-pane ( style pane -- pane )
+: apply-paragraph-style ( style pane -- pane )
     apply-inset-style
     apply-border-color-style
     apply-page-color-style
     apply-presentation-style
     nip ;
 
-TUPLE: nested-pane-stream < style-stream parent ;
+: remove-paragraph-styles ( style -- style' )
+    [
+        drop HS{
+            wrap-margin border-color page-color inset presented
+        } in?
+    ] assoc-reject ;
 
-: new-nested-pane-stream ( style parent class -- stream )
+TUPLE: styled-pane < pane style ;
-    [ <pane> apply-wrap-style <pane-stream> swap ] 2dip boa ; inline
 
-: unnest-pane-stream ( stream -- child parent )
+: <styled-pane> ( style -- pane )
-    [ style>> ] [ stream>> pane>> smash-pane style-pane ] [ parent>> ] tri ;
+    f styled-pane new-pane apply-wrap-style swap >>style ;
 
-TUPLE: pane-block-stream < nested-pane-stream ;
+M: styled-pane smash-pane
+    [ style>> ] [ call-next-method apply-paragraph-style ] bi ;
 
-M: pane-block-stream dispose
+: <styled-pane-stream> ( style pane-stream -- styled-stream )
-    unnest-pane-stream write-gadget ;
+    over
+    [ <styled-pane> ]
+    [ pane-stream boa ]
+    [ remove-paragraph-styles <style-stream> ] tri* ;
+
+: make-styled-pane ( style quot -- gadget )
+    [ <styled-pane> ] dip '[ _ with-pane ] keep smash-pane ; inline
 
 M: pane-stream make-block-stream
-    pane-block-stream new-nested-pane-stream ;
+    <styled-pane-stream> ;
 
 ! Tables
 
@@ -301,67 +316,48 @@ M: pane-stream make-block-stream
 : apply-table-border-style ( style grid -- style grid )
     table-border [ <grid-lines> >>boundary ] apply-style ;
 
-: styled-grid ( style grid -- grid )
+: <styled-grid> ( style grid -- grid )
     <grid>
     f >>fill?
     apply-table-gap-style
     apply-table-border-style
-    nip ;
+    apply-paragraph-style ;
-
-TUPLE: pane-cell-stream < nested-pane-stream ;
-
-M: pane-cell-stream dispose drop ;
 
 M: pane-stream make-cell-stream
-    pane-cell-stream new-nested-pane-stream ;
+    drop f <styled-pane-stream> ;
 
 M: pane-stream stream-write-table
     [
         swap [ [ stream>> pane>> smash-pane ] map ] map
-        styled-grid
+        <styled-grid>
     ] dip write-gadget ;
 
 ! Stream utilities
 
-: gadget-write ( string gadget -- )
+: pane-bl ( style gadget -- )
-    swap dup empty?
+    swap " " <word-break-gadget> apply-character-style add-gadget drop ;
-    [ 2drop ] [ <label> monospace-font >>font add-gadget drop ] if ;
 
-M: pack pane-write gadget-write ;
+: <styled-label> ( style text -- gadget )
+    [
+        <label>
+        apply-font-style
+        apply-background-style
+        apply-image-style
+    ] keep [ blank? ] all? [
+        apply-presentation-style
+    ] unless nip ;
 
-: gadget-bl ( style stream -- )
+: pane-text ( string style gadget -- )
-    swap " " <word-break-gadget> style-label add-gadget drop ;
+    [ swap <styled-label> ] [ swap add-gadget drop ] bi* ;
 
-M: paragraph pane-write
+M: pack pane-line pane-text ;
-    swap " " split
-    [ H{ } over gadget-bl ] [ over gadget-write ] interleave
-    drop ;
 
-: gadget-write1 ( char gadget -- )
+M: paragraph pane-line
-    [ 1string ] dip pane-write ;
+    { presented image-style } pick '[ _ key? ] any? [
-
+        pane-text
-M: pack pane-write1 gadget-write1 ;
-
-M: paragraph pane-write1
-    over CHAR: \s =
-    [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
-
-: empty-output? ( string style -- ? )
-    [ empty? ] [ image-style swap key? not ] bi* and ;
-
-: gadget-format ( string style stream -- )
-    [ [ empty-output? ] 2keep ] dip
-    '[ _ _ swap <styled-label> _ swap add-gadget drop ] unless ;
-
-M: pack pane-format
-    gadget-format ;
-
-M: paragraph pane-format
-    over { presented image-style } [ swap key? ] with any? [
-        gadget-format
     ] [
         [ " " split ] 2dip
-        [ gadget-bl ] [ gadget-format ] bi-curry bi-curry
+        [ pane-bl ] [ pane-text ] bi-curry bi-curry
         interleave
     ] if ;
 
@@ -445,4 +441,5 @@ pane H{
 } set-gestures
 
 GENERIC: content-gadget ( object -- gadget/f )
+
 M: object content-gadget drop f ;