From 27b745dcc8730e6d82c014ad7ac8f8f491110848 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 24 May 2009 09:36:24 -0500 Subject: [PATCH] modulization of ui.frp --- basis/functors/functors.factor | 10 +- core/sequences/sequences.factor | 4 +- extra/modules/util/util.factor | 7 + extra/monads/monads.factor | 1 + extra/ui/frp/frp.factor | 169 +----------------- extra/ui/frp/functors/functors.factor | 25 +++ extra/ui/frp/gadgets/gadgets.factor | 26 +++ extra/ui/frp/instances/instances.factor | 12 ++ extra/ui/frp/layout/layout.factor | 34 ++++ extra/ui/frp/signals/signals.factor | 81 +++++++++ .../frp/{frp-docs.factor => xfrp-docs.factor} | 0 11 files changed, 200 insertions(+), 169 deletions(-) create mode 100644 extra/modules/util/util.factor create mode 100644 extra/ui/frp/functors/functors.factor create mode 100644 extra/ui/frp/gadgets/gadgets.factor create mode 100644 extra/ui/frp/instances/instances.factor create mode 100644 extra/ui/frp/layout/layout.factor create mode 100644 extra/ui/frp/signals/signals.factor rename extra/ui/frp/{frp-docs.factor => xfrp-docs.factor} (100%) diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index edd4932c66..bf7eed8f8a 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -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 } } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 51df596278..a86c501258 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -927,4 +927,6 @@ PRIVATE> list empty? [ identity ] [ list rest identity quot reduce-r list first quot call ] if ; - inline recursive \ No newline at end of file + inline recursive + +:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ; \ No newline at end of file diff --git a/extra/modules/util/util.factor b/extra/modules/util/util.factor new file mode 100644 index 0000000000..ef5a3f3e76 --- /dev/null +++ b/extra/modules/util/util.factor @@ -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 ] ; \ No newline at end of file diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index 6b35772596..f4503cbdd3 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -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 ) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index ccae6fe4b0..f97dccdc03 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -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 -- ) -: ( 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 ; -: ( models -- model ) basic-model ; -: ( 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 ; -: ( model quot -- filter-model ) [ 1array filter-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 ; -: ( oldval quot model -- model' ) 1array fold-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 ; -: ( values updates -- updater ) [ 2array updater-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 ; -: ( signal1 signal2 -- signal' ) [ 2array switch-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 - swap >>quot swap >>model ; -: ( 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 ; -: ( models -- product ) frp-product ; -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 ; -: ( 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 ; -: ( model quot -- action ) [ 1array action ] dip >>quot dup f >>value value>> ; - -! Gadgets -TUPLE: frp-button < button hook ; -: ( text -- button ) [ - [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep - t swap set-control-value - ] frp-button new-button border-button-theme f >>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* ; - -: ( model -- table ) f frp-table new-table dup >>renderer - V{ } clone >>selected-values V{ } clone >>selected-indices* ; -: ( -- table ) V{ } clone ; -: ( model -- table ) [ 1array ] >>quot ; -: ( -- table ) V{ } clone ; -: indexed ( table -- table ) f >>val-quot ; - -: ( -- field ) "" ; - -! Layout utilities -TUPLE: layout gadget width ; C: 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 make:, ; -M: model , activate-model ; - -SYNTAX: ,% scan string>number [ make:, ] curry over push-all ; -SYNTAX: ->% scan string>number '[ [ _ make:, ] [ output-model ] bi ] over push-all ; - -GENERIC: -> ( uiitem -- model ) -M: gadget -> dup , output-model ; -M: model -> dup , ; - -: ( -- ) 1 make:, ; -: ( gadgets type -- track ) - [ { } make:make ] dip swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline -: ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline -: ( gadgets -- track ) horizontal ; inline -: ( gadgets -- track ) horizontal ; inline -: ( gadgets -- track ) vertical ; inline -: ( gadgets -- track ) vertical ; inline - -! Instances -M: model fmap ; -M: model >>= [ swap ] curry ; - -SINGLETON: gadget-monad -INSTANCE: gadget-monad monad -INSTANCE: gadget monad -M: gadget monad-of drop gadget-monad ; -M: gadget-monad return drop swap >>model ; -M: gadget >>= output-model [ swap call( x -- y ) ] curry ; - -! Macros -: lift ( int -- quot ) dup - '[ [ _ narray ] dip [ _ firstn ] prepend ] ; inline - -MACRO: liftA-n ( int -- quot ) lift [ ] 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 \ No newline at end of file +EXPORT-FROM: ui.frp.signals ui.frp.gadgets ui.frp.instances ui.frp.layout ; +FMAPS: $> <$ fmap FOR & | ; \ No newline at end of file diff --git a/extra/ui/frp/functors/functors.factor b/extra/ui/frp/functors/functors.factor new file mode 100644 index 0000000000..2808faf190 --- /dev/null +++ b/extra/ui/frp/functors/functors.factor @@ -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} +

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

] 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 = +token = !("FOR"|";"). +middle = "FOR" => [[ drop ignore ]] +endexpr = ";" => [[ drop ignore ]] +expr = token* middle token* endexpr => [[ first2 combos [ first2 fmaps ] each ignore ]] +;ON-BNF \ No newline at end of file diff --git a/extra/ui/frp/gadgets/gadgets.factor b/extra/ui/frp/gadgets/gadgets.factor new file mode 100644 index 0000000000..02bc8f45cb --- /dev/null +++ b/extra/ui/frp/gadgets/gadgets.factor @@ -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 ; +: ( text -- button ) [ + [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep + t swap set-control-value + ] frp-button new-button border-button-theme f >>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* ; + +: ( model -- table ) f frp-table new-table dup >>renderer + V{ } clone >>selected-values V{ } clone >>selected-indices* ; +: ( -- table ) V{ } clone ; +: ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) V{ } clone ; +: indexed ( table -- table ) f >>val-quot ; + +: ( -- field ) "" ; \ No newline at end of file diff --git a/extra/ui/frp/instances/instances.factor b/extra/ui/frp/instances/instances.factor new file mode 100644 index 0000000000..8ab7531621 --- /dev/null +++ b/extra/ui/frp/instances/instances.factor @@ -0,0 +1,12 @@ +USING: accessors kernel models monads ui.frp.signals ui.frp.layout ui.gadgets ; +IN: ui.frp.instances + +M: model >>= [ swap ] curry ; +M: model fmap ; + +SINGLETON: gadget-monad +INSTANCE: gadget-monad monad +INSTANCE: gadget monad +M: gadget monad-of drop gadget-monad ; +M: gadget-monad return drop swap >>model ; +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor new file mode 100644 index 0000000000..508f30b2ab --- /dev/null +++ b/extra/ui/frp/layout/layout.factor @@ -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 + +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 make:, ; +M: model , activate-model ; + +SYNTAX: ,% scan string>number [ make:, ] curry over push-all ; +SYNTAX: ->% scan string>number '[ [ _ make:, ] [ output-model ] bi ] over push-all ; + +GENERIC: -> ( uiitem -- model ) +M: gadget -> dup , output-model ; +M: model -> dup , ; + +: ( -- ) 1 make:, ; +: ( gadgets type -- track ) + [ { } make:make ] dip swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline +: ( gadgets type -- track ) [ ] [ [ model>> ] map <|> ] bi >>model ; inline +: ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline \ No newline at end of file diff --git a/extra/ui/frp/signals/signals.factor b/extra/ui/frp/signals/signals.factor new file mode 100644 index 0000000000..461b8f0732 --- /dev/null +++ b/extra/ui/frp/signals/signals.factor @@ -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 -- ) +: ( 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 ; +: ( models -- model ) basic-model ; +: ( 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 ; +: ( model quot -- filter-model ) [ 1array filter-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 ; +: ( oldval quot model -- model' ) 1array fold-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 ; +: ( values updates -- updater ) [ 2array updater-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 ; +: ( signal1 signal2 -- signal' ) [ 2array switch-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 + swap >>quot swap >>model ; +: ( 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 ; +: ( 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 ; +: ( model quot -- action ) [ 1array action ] dip >>quot dup f >>value value>> ; + +TUPLE: | < multi-model ; +: <|> ( models -- product ) | ; +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 ) & ; +M: & model-changed [ call-next-method ] keep + [ dependencies>> [ f swap set-model ] each ] with-locked-model ; \ No newline at end of file diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/xfrp-docs.factor similarity index 100% rename from extra/ui/frp/frp-docs.factor rename to extra/ui/frp/xfrp-docs.factor -- 2.34.1