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

modulization of ui.frp

db4
Sam Anklesaria 2009-05-24 09:36:24 -05:00
parent f5b539bb00
commit 27b745dcc8
11 changed files with 200 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/functors/functors.factor
View File

@ -4,8 +4,8 @@ USING: accessors arrays classes.mixin classes.parser
classes.tuple classes.tuple.parser combinators effects
effects.parser fry generic generic.parser generic.standard
interpolate io.streams.string kernel lexer locals.parser
locals.rewrite.closures locals.types make namespaces parser
quotations sequences vocabs.parser words words.symbol ;
locals.rewrite.closures locals.types make macros namespaces
parser quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
@ -111,6 +111,11 @@ SYNTAX: `GENERIC:
complete-effect parsed
\ define-simple-generic* parsed ;
SYNTAX: `MACRO:
scan-param parsed
parse-declared*
\ define-macro parsed ;
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
@ -142,6 +147,7 @@ DEFER: ;FUNCTOR delimiter
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
{ "MACRO:" POSTPONE: `MACRO: }
{ "call-next-method" POSTPONE: `call-next-method }
} ;

4
core/sequences/sequences.factor
View File

@ -927,4 +927,6 @@ PRIVATE>
list empty?
[ identity ]
[ list rest identity quot reduce-r list first quot call ] if ;
inline recursive
inline recursive
:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;

7
extra/modules/util/util.factor Normal file
View File

@ -0,0 +1,7 @@
USING: accessors assocs kernel lexer locals namespaces sequences
vocabs vocabs.parser ;
IN: modules.util
SYNTAX: EXPORT-FROM: [let | v [ in get ] |
v vocab words>> ";" parse-tokens
[ load-vocab vocab-words [ clone v >>vocabulary ] assoc-map ] map
assoc-combine update ] ;

1
extra/monads/monads.factor
View File

@ -22,6 +22,7 @@ M: monad return monad-of return ;
M: monad fail monad-of fail ;
: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
: bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
:: lift-m2 ( m1 m2 f monad -- m3 )

169
extra/ui/frp/frp.factor
View File

@ -1,167 +1,4 @@
USING: accessors arrays colors fonts fry generalizations kernel
lexer macros math math.parser models models.product monads
sequences ui.gadgets ui.gadgets.buttons ui.gadgets.buttons.private
ui.gadgets.editors ui.gadgets.scrollers ui.gadgets.tables
ui.gadgets.tracks ;
QUALIFIED: make
USING: modules.util ui.frp.functors monads ;
IN: ui.frp
! !!! Model utilities
TUPLE: multi-model < model ;
GENERIC: (model-changed) ( model observer -- )
: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
M: multi-model model-activated dup dependencies>> dup length 1 =
[ first swap model-changed ] [ 2drop ] if ;
TUPLE: basic-model < multi-model ;
M: basic-model (model-changed) [ value>> ] dip set-model ;
: <merge> ( models -- model ) basic-model <multi-model> ;
: <basic> ( value -- model ) basic-model new-model ;
TUPLE: filter-model < multi-model quot ;
M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
[ set-model ] [ 2drop ] if ;
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
TUPLE: fold-model < multi-model oldval quot ;
M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
call( val oldval -- newval ) ] keep set-model ;
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
swap [ >>oldval ] [ >>value ] bi ;
TUPLE: updater-model < multi-model values updates ;
M: updater-model (model-changed) tuck updates>> =
[ [ values>> value>> ] keep set-model ]
[ drop ] if ;
: <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
[ >>values ] [ >>updates ] bi* ;
TUPLE: switch-model < multi-model original switcher on ;
M: switch-model (model-changed) 2dup switcher>> =
[ [ value>> ] [ t >>on ] bi* set-model ]
[ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
[ >>original ] [ >>switcher ] bi* ;
M: switch-model model-activated [ original>> ] keep model-changed ;
TUPLE: mapped-model < multi-model model quot ;
: new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
<multi-model> swap >>quot swap >>model ;
: <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
M: mapped-model (model-changed)
[ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
set-model ;
TUPLE: side-effect-model < mapped-model ;
M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
: $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
TUPLE: quot-model < mapped-model ;
M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
: <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
TUPLE: frp-product < multi-model ;
: <frp-product> ( models -- product ) frp-product <multi-model> ;
M: frp-product model-changed
nip
dup dependencies>> [ value>> ] all?
[ dup [ value>> ] product-value >>value notify-connections
] [ drop ] if ;
M: frp-product update-model
dup value>> swap [ set-model ] set-product-value ;
M: frp-product model-activated dup model-changed ;
TUPLE: action-value < basic-model parent ;
: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
! Update at start
TUPLE: action < multi-model quot ;
M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
[ swap add-connection ] 2keep model-changed ;
: <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
! Gadgets
TUPLE: frp-button < button hook ;
: <frp-button> ( text -- button ) [
[ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
t swap set-control-value
] frp-button new-button border-button-theme f <basic> >>model ;
TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ;
M: frp-table column-titles column-titles>> ;
M: frp-table column-alignment column-alignment>> ;
M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
: <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices* ;
: <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
: <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
: indexed ( table -- table ) f >>val-quot ;
: <frp-field> ( -- field ) "" <model> <model-field> ;
! Layout utilities
TUPLE: layout gadget width ; C: <layout> layout
GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ;
M: table output-model dup multiple-selection?>>
[ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
[ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
M: model-field output-model field-model>> ;
M: scroller output-model viewport>> children>> first output-model ;
GENERIC: , ( uiitem -- )
M: gadget , f <layout> make:, ;
M: model , activate-model ;
SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
GENERIC: -> ( uiitem -- model )
M: gadget -> dup , output-model ;
M: model -> dup , ;
: <spacer> ( -- ) <gadget> 1 <layout> make:, ;
: <box> ( gadgets type -- track )
[ { } make:make ] dip <track> swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline
: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
! Instances
M: model fmap <mapped> ;
M: model >>= [ swap <action> ] curry ;
SINGLETON: gadget-monad
INSTANCE: gadget-monad monad
INSTANCE: gadget monad
M: gadget monad-of drop gadget-monad ;
M: gadget-monad return drop <gadget> swap >>model ;
M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
! Macros
: lift ( int -- quot ) dup
'[ [ _ narray <frp-product> ] dip [ _ firstn ] prepend ] ; inline
MACRO: liftA-n ( int -- quot ) lift [ <mapped> ] append ;
MACRO: $>-n ( int -- quot ) lift [ $> ] append ;
MACRO: <$-n ( int -- quot ) lift [ <$ ] append ;
: liftA2 ( a b quot -- arrow ) 2 liftA-n ; inline
: liftA3 ( a b c quot -- arrow ) 3 liftA-n ; inline
: $>2 ( a b quot -- arrow ) 2 $>-n ; inline
: $>3 ( a b c quot -- arrow ) 3 $>-n ; inline
: <$2 ( a b quot -- arrow ) 2 <$-n ; inline
: <$3 ( a b c quot -- arrow ) 3 <$-n ; inline
EXPORT-FROM: ui.frp.signals ui.frp.gadgets ui.frp.instances ui.frp.layout ;
FMAPS: $> <$ fmap FOR & | ;

25
extra/ui/frp/functors/functors.factor Normal file
View File

@ -0,0 +1,25 @@
USING: fry functors generalizations kernel macros peg peg-lexer
sequences ;
IN: ui.frp.functors
FUNCTOR: fmaps ( W P -- )
W IS ${W}
<p> IS <${P}>
w-n DEFINES ${W}-n-${P}
w-2 DEFINES 2${W}-${P}
w-3 DEFINES 3${W}-${P}
w-4 DEFINES 4${W}-${P}
WHERE
MACRO: w-n ( int -- quot ) dup '[ [ _ narray <p> ] dip [ _ firstn ] prepend W ] ;
: w-2 ( a b quot -- mapped ) 2 w-n ; inline
: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
;FUNCTOR
ON-BNF: FMAPS:
tokenizer = <foreign factor>
token = !("FOR"|";").
middle = "FOR" => [[ drop ignore ]]
endexpr = ";" => [[ drop ignore ]]
expr = token* middle token* endexpr => [[ first2 combos [ first2 fmaps ] each ignore ]]
;ON-BNF

26
extra/ui/frp/gadgets/gadgets.factor Normal file
View File

@ -0,0 +1,26 @@
USING: accessors arrays kernel models ui.frp.signals ui.gadgets
ui.gadgets.buttons ui.gadgets.buttons.private
ui.gadgets.editors ui.gadgets.tables ;
IN: ui.frp.gadgets
TUPLE: frp-button < button hook ;
: <frp-button> ( text -- button ) [
[ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
t swap set-control-value
] frp-button new-button border-button-theme f <basic> >>model ;
TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ;
M: frp-table column-titles column-titles>> ;
M: frp-table column-alignment column-alignment>> ;
M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
: <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices* ;
: <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
: <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
: indexed ( table -- table ) f >>val-quot ;
: <frp-field> ( -- field ) "" <model> <model-field> ;

12
extra/ui/frp/instances/instances.factor Normal file
View File

@ -0,0 +1,12 @@
USING: accessors kernel models monads ui.frp.signals ui.frp.layout ui.gadgets ;
IN: ui.frp.instances
M: model >>= [ swap <action> ] curry ;
M: model fmap <mapped> ;
SINGLETON: gadget-monad
INSTANCE: gadget-monad monad
INSTANCE: gadget monad
M: gadget monad-of drop gadget-monad ;
M: gadget-monad return drop <gadget> swap >>model ;
M: gadget >>= output-model [ swap call( x -- y ) ] curry ;

34
extra/ui/frp/layout/layout.factor Normal file
View File

@ -0,0 +1,34 @@
USING: accessors fry kernel lexer math.parser models sequences
ui.frp.signals ui.gadgets ui.gadgets.editors ui.gadgets.scrollers
ui.gadgets.tables ui.gadgets.tracks ;
QUALIFIED: make
IN: ui.frp.layout
TUPLE: layout gadget width ; C: <layout> layout
GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ;
M: table output-model dup multiple-selection?>>
[ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
[ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
M: model-field output-model field-model>> ;
M: scroller output-model viewport>> children>> first output-model ;
GENERIC: , ( uiitem -- )
M: gadget , f <layout> make:, ;
M: model , activate-model ;
SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
GENERIC: -> ( uiitem -- model )
M: gadget -> dup , output-model ;
M: model -> dup , ;
: <spacer> ( -- ) <gadget> 1 <layout> make:, ;
: <box> ( gadgets type -- track )
[ { } make:make ] dip <track> swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <|> ] bi >>model ; inline
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline
: <vbox*> ( gadgets -- track ) vertical <box*> ; inline

81
extra/ui/frp/signals/signals.factor Normal file
View File

@ -0,0 +1,81 @@
USING: accessors arrays kernel models models.product sequences ;
IN: ui.frp.signals
TUPLE: multi-model < model ;
GENERIC: (model-changed) ( model observer -- )
: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
M: multi-model model-activated dup dependencies>> dup length 1 =
[ first swap model-changed ] [ 2drop ] if ;
TUPLE: basic-model < multi-model ;
M: basic-model (model-changed) [ value>> ] dip set-model ;
: <merge> ( models -- model ) basic-model <multi-model> ;
: <basic> ( value -- model ) basic-model new-model ;
TUPLE: filter-model < multi-model quot ;
M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
[ set-model ] [ 2drop ] if ;
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
TUPLE: fold-model < multi-model oldval quot ;
M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
call( val oldval -- newval ) ] keep set-model ;
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
swap [ >>oldval ] [ >>value ] bi ;
TUPLE: updater-model < multi-model values updates ;
M: updater-model (model-changed) tuck updates>> =
[ [ values>> value>> ] keep set-model ]
[ drop ] if ;
: <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
[ >>values ] [ >>updates ] bi* ;
TUPLE: switch-model < multi-model original switcher on ;
M: switch-model (model-changed) 2dup switcher>> =
[ [ value>> ] [ t >>on ] bi* set-model ]
[ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
[ >>original ] [ >>switcher ] bi* ;
M: switch-model model-activated [ original>> ] keep model-changed ;
TUPLE: mapped-model < multi-model model quot ;
: new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
<multi-model> swap >>quot swap >>model ;
: <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
M: mapped-model (model-changed)
[ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
set-model ;
TUPLE: side-effect-model < mapped-model ;
M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
: $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
TUPLE: quot-model < mapped-model ;
M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
: <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
TUPLE: action-value < basic-model parent ;
: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
TUPLE: action < multi-model quot ;
M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
[ swap add-connection ] 2keep model-changed ;
: <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
TUPLE: | < multi-model ;
: <|> ( models -- product ) | <multi-model> ;
M: | model-changed
nip
dup dependencies>> [ value>> ] all?
[ dup [ value>> ] product-value >>value notify-connections
] [ drop ] if ;
M: | update-model
dup value>> swap [ set-model ] set-product-value ;
M: | model-activated dup model-changed ;
TUPLE: & < | ;
: <&> ( models -- product ) & <multi-model> ;
M: & model-changed [ call-next-method ] keep
[ dependencies>> [ f swap set-model ] each ] with-locked-model ;

0
extra/ui/frp/frp-docs.factor → extra/ui/frp/xfrp-docs.factor
View File