monadic binding for models (frp)

diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor
index 459d52983fbb2ada6deadcd0bb8de7312881a24b..e66ee0e89a2151080f18854e0b4c77e7721a7727 100644 (file)
--- a/extra/ui/frp/frp.factor
+++ b/extra/ui/frp/frp.factor
@@ -43,26 +43,22 @@ M: switch-model (model-changed) 2dup switcher>> =
    [ >>original ] [ >>switcher ] bi* ;
 M: switch-model model-activated [ original>> ] keep model-changed ;
 
-
 TUPLE: mapped-model < multi-model model quot ;
- 
-: <mapped> ( model quot -- mapped )
-    f mapped-model new-model
-        swap >>quot
-        over >>model
-        [ add-dependency ] keep ;
+: 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 ;
 M: mapped-model model-activated [ model>> ] keep model-changed ;
 
 TUPLE: side-effect-model < mapped-model ;
-M: side-effect-model (model-changed) [ value>> ] [ quot>> ] bi* call( old -- ) ;
-: <$ ( model quot -- side-effect-model )
-   f side-effect-model new-model
-     swap >>quot
-     over >>model
-     [ add-dependency ] keep ;
+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> ;
@@ -75,6 +71,15 @@ 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 parent>> activate-model ; ! 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 ;
+: <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 ) [
@@ -131,6 +136,7 @@ M: model -> dup , ;
 
 ! Instances
 M: model fmap <mapped> ;
+M: model >>= [ swap <action> ] curry ;
 
 SINGLETON: gadget-monad
 INSTANCE: gadget-monad monad
@@ -140,15 +146,20 @@ 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: liftA-n ( int -- quot ) dup
-   '[ [ _ narray <frp-product> ] dip [ _ firstn ] prepend <mapped> ] ;
+MACRO: $>-n ( int -- quot ) lift [ $> ] append ;
 
-MACRO: <$-n ( int -- quot ) dup
-   '[ [ _ narray <frp-product> ] dip [ _ firstn ] prepend <$ ] ;
+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

diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor
index 8cb6a3fd086122f948aaeae751a0ffc1a6ef592a..38a3f539a7af78e91f70095abaca5c7f510f2422 100644 (file)
--- a/extra/ui/gadgets/alerts/alerts.factor
+++ b/extra/ui/gadgets/alerts/alerts.factor
@@ -12,7 +12,7 @@ IN: ui.gadgets.alerts
             fldm [ <frp-field> ->% 1 ]
             btn  [ "okay" <frp-button> model >>model ] |
          btn -> [ fldm swap <updates> ]
-                [ [ drop lbl close-window ] <$ , ] bi
+                [ [ drop lbl close-window ] $> , ] bi
    ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
 
 : ask-user ( string -- model ) f <model> swap ask-user* ;
\ No newline at end of file