ui.gadgets.panes: change approach to nested-pane-stream.
John Benediktsson
parent
2b2eb4be59
commit
612a6999c9
|
|
@ -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
|
||||
splitting strings ui.baseline-alignment ui.clipboards ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.grid-lines ui.gadgets.grids
|
||||
ui.gadgets.icons ui.gadgets.incremental ui.gadgets.labels
|
||||
ui.gadgets.menus ui.gadgets.packs ui.gadgets.paragraphs
|
||||
ui.gadgets.presentations ui.gadgets.private ui.gadgets.scrollers
|
||||
ui.gadgets.tracks ui.gestures ui.images ui.pens.solid ui.render
|
||||
ui.theme ui.traverse unicode ;
|
||||
math.rectangles math.vectors models namespaces sequences sets
|
||||
sorting splitting strings ui.baseline-alignment ui.clipboards
|
||||
ui.gadgets ui.gadgets.borders ui.gadgets.grid-lines
|
||||
ui.gadgets.grids ui.gadgets.icons ui.gadgets.incremental
|
||||
ui.gadgets.labels ui.gadgets.menus ui.gadgets.packs
|
||||
ui.gadgets.paragraphs ui.gadgets.presentations
|
||||
ui.gadgets.private ui.gadgets.scrollers ui.gadgets.tracks
|
||||
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 )
|
||||
selected-subtree gadget-text ;
|
||||
M: pane gadget-selection 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-write1 ( char gadget -- )
|
||||
GENERIC: pane-format ( str style gadget -- )
|
||||
GENERIC: pane-line ( str style gadget -- )
|
||||
|
||||
M: pane pane-write
|
||||
[ pane-nl ] [ current>> pane-write ]
|
||||
bi-curry interleave ;
|
||||
|
||||
M: pane pane-format
|
||||
[ nip pane-nl ] [ current>> pane-format ]
|
||||
: pane-format ( lines style pane -- )
|
||||
[ nip pane-nl ] [ current>> pane-line ]
|
||||
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 )
|
||||
[ <pane> apply-wrap-style <pane-stream> swap ] 2dip boa ; inline
|
||||
TUPLE: styled-pane < pane style ;
|
||||
|
||||
: unnest-pane-stream ( stream -- child parent )
|
||||
[ style>> ] [ stream>> pane>> smash-pane style-pane ] [ parent>> ] tri ;
|
||||
: <styled-pane> ( style -- pane )
|
||||
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
|
||||
unnest-pane-stream write-gadget ;
|
||||
: <styled-pane-stream> ( style pane-stream -- styled-stream )
|
||||
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 ;
|
||||
|
||||
TUPLE: pane-cell-stream < nested-pane-stream ;
|
||||
|
||||
M: pane-cell-stream dispose drop ;
|
||||
apply-paragraph-style ;
|
||||
|
||||
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 -- )
|
||||
swap dup empty?
|
||||
[ 2drop ] [ <label> monospace-font >>font add-gadget drop ] if ;
|
||||
: pane-bl ( style gadget -- )
|
||||
swap " " <word-break-gadget> apply-character-style add-gadget drop ;
|
||||
|
||||
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 -- )
|
||||
swap " " <word-break-gadget> style-label add-gadget drop ;
|
||||
: pane-text ( string style gadget -- )
|
||||
[ swap <styled-label> ] [ swap add-gadget drop ] bi* ;
|
||||
|
||||
M: paragraph pane-write
|
||||
swap " " split
|
||||
[ H{ } over gadget-bl ] [ over gadget-write ] interleave
|
||||
drop ;
|
||||
M: pack pane-line pane-text ;
|
||||
|
||||
: gadget-write1 ( char gadget -- )
|
||||
[ 1string ] dip pane-write ;
|
||||
|
||||
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
|
||||
M: paragraph pane-line
|
||||
{ presented image-style } pick '[ _ key? ] any? [
|
||||
pane-text
|
||||
] [
|
||||
[ " " 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue