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

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

flac
John Benediktsson 2020-02-19 19:54:53 -08:00 committed by Steve Ayerhart
parent 2b2eb4be59
commit 612a6999c9
No known key found for this signature in database
GPG Key ID: 5BFD39C5359E967D
1 changed files with 82 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

167
basis/ui/gadgets/panes/panes.factor
View File

@ -2,14 +2,15 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs classes combinators destructors USING: accessors assocs classes combinators destructors
documents.private fonts fry io io.styles kernel locals math 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: io.styles => foreground background ;
FROM: ui.gadgets.wrappers => <wrapper> ; FROM: ui.gadgets.wrappers => <wrapper> ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
@ -18,13 +19,16 @@ TUPLE: pane < track
output current input last-line prototype scrolls? output current input last-line prototype scrolls?
selection-color caret mark selecting? ; selection-color caret mark selecting? ;
TUPLE: pane-stream pane ; TUPLE: pane-stream pane parent ;
INSTANCE: pane-stream output-stream 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+ ; M: pane-stream stream-element-type drop +character+ ;
DEFER: write-gadget
<PRIVATE <PRIVATE
: clear-selection ( pane -- pane ) : 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-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 ) : init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline <shelf> +baseline+ >>align >>prototype ; inline
@ -97,21 +100,23 @@ M: pane selected-children
add-incremental add-incremental
] [ next-line ] bi ; ] [ next-line ] bi ;
: smash-pane ( pane -- gadget ) GENERIC: smash-pane ( pane -- gadget )
M: pane smash-pane
[ pane-nl ] [ output>> smash-line ] bi ; [ 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 ; 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 -- ) : do-pane-stream ( pane-stream quot -- )
[ pane>> ] dip keep scroll-pane ; inline [ pane>> ] dip keep scroll-pane ; inline
@ -119,7 +124,7 @@ M: pane-stream stream-nl
[ pane-nl ] do-pane-stream ; [ pane-nl ] do-pane-stream ;
M: pane-stream stream-write1 M: pane-stream stream-write1
[ current>> pane-write1 ] do-pane-stream ; [ pane-write1 ] do-pane-stream ;
: split-pane ( str quot: ( str -- ) -- ) : split-pane ( str quot: ( str -- ) -- )
'[ '[
@ -134,7 +139,12 @@ M: pane-stream stream-write
M: pane-stream stream-format M: pane-stream stream-format
[ '[ _ _ pane-format ] split-pane ] do-pane-stream ; [ '[ _ _ 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 ; M: pane-stream stream-flush drop ;
@ -167,12 +177,9 @@ M: object write-gadget
M: filter-writer write-gadget M: filter-writer write-gadget
stream>> write-gadget ; stream>> write-gadget ;
M: pane-stream write-gadget ( gadget pane-stream -- ) M: pane-stream write-gadget
pane>> current>> swap add-gadget drop ; pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget
stream>> write-gadget ;
: print-gadget ( gadget stream -- ) : print-gadget ( gadget stream -- )
[ write-gadget ] [ nip stream-nl ] 2bi ; [ write-gadget ] [ nip stream-nl ] 2bi ;
@ -190,7 +197,7 @@ M: style-stream write-gadget
with-output-stream* ; inline with-output-stream* ; inline
: make-pane ( quot -- gadget ) : 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 ; 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 ) : apply-background-style ( style gadget -- style gadget )
background [ <solid> >>interior ] apply-style ; background [ <solid> >>interior ] apply-style ;
: style-label ( style gadget -- gadget ) : apply-character-style ( style gadget -- gadget )
apply-font-style apply-font-style
apply-background-style apply-background-style
apply-presentation-style
apply-image-style apply-image-style
apply-presentation-style
nip ; inline nip ; inline
: <styled-label> ( style text -- gadget )
<label> style-label ;
! Paragraph styles ! Paragraph styles
: apply-wrap-style ( style pane -- style pane ) : 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 ) : apply-inset-style ( style gadget -- style gadget )
inset [ <border> ] apply-style ; inset [ <border> ] apply-style ;
: style-pane ( style pane -- pane ) : apply-paragraph-style ( style pane -- pane )
apply-inset-style apply-inset-style
apply-border-color-style apply-border-color-style
apply-page-color-style apply-page-color-style
apply-presentation-style apply-presentation-style
nip ; 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 M: pane-stream make-block-stream
pane-block-stream new-nested-pane-stream ; <styled-pane-stream> ;
! Tables ! Tables
@ -301,67 +316,48 @@ M: pane-stream make-block-stream
: apply-table-border-style ( style grid -- style grid ) : apply-table-border-style ( style grid -- style grid )
table-border [ <grid-lines> >>boundary ] apply-style ; table-border [ <grid-lines> >>boundary ] apply-style ;
: styled-grid ( style grid -- grid ) : <styled-grid> ( style grid -- grid )
<grid> <grid>
f >>fill? f >>fill?
apply-table-gap-style apply-table-gap-style
apply-table-border-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 M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ; drop f <styled-pane-stream> ;
M: pane-stream stream-write-table M: pane-stream stream-write-table
[ [
swap [ [ stream>> pane>> smash-pane ] map ] map swap [ [ stream>> pane>> smash-pane ] map ] map
styled-grid <styled-grid>
] dip write-gadget ; ] dip write-gadget ;
! Stream utilities ! 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 [ " " split ] 2dip
[ gadget-bl ] [ gadget-format ] bi-curry bi-curry [ pane-bl ] [ pane-text ] bi-curry bi-curry
interleave interleave
] if ; ] if ;
@ -445,4 +441,5 @@ pane H{
} set-gestures } set-gestures
GENERIC: content-gadget ( object -- gadget/f ) GENERIC: content-gadget ( object -- gadget/f )
M: object content-gadget drop f ; M: object content-gadget drop f ;