From 77a128fc331bf41cf7aacf6dff2f960adad8acb8 Mon Sep 17 00:00:00 2001
From: Sam Anklesaria <sam@Tintin.local>
Date: Mon, 27 Jul 2009 21:44:18 -0500
Subject: [PATCH] some non-reflective frp deployment working

---
 extra/monads/monads.factor            |  1 +
 extra/persistency/persistency.factor  |  5 ++---
 extra/ui/frp/gadgets/gadgets.factor   | 15 +++++++++------
 extra/ui/frp/layout/layout.factor     |  9 ++++++---
 extra/ui/frp/signals/signals.factor   |  4 ----
 extra/ui/gadgets/alerts/alerts.factor |  2 +-
 6 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
index 9a3e605c7f..a859c36f2e 100644
--- a/extra/monads/monads.factor
+++ b/extra/monads/monads.factor
@@ -8,6 +8,7 @@ IN: monads
 ! Functors
 GENERIC# fmap 1 ( functor quot -- functor' )
 GENERIC# <$ 1 ( functor quot -- functor' )
+GENERIC# $> 1 ( functor quot -- functor' )
 
 ! Monads
 
diff --git a/extra/persistency/persistency.factor b/extra/persistency/persistency.factor
index 479d39a2b7..8100bce353 100644
--- a/extra/persistency/persistency.factor
+++ b/extra/persistency/persistency.factor
@@ -1,7 +1,6 @@
 USING: accessors arrays byte-arrays calendar classes classes.tuple
 classes.tuple.parser combinators db db.tuples db.types kernel
-math prettyprint sequences strings unicode.case urls words
-tools.continuations ;
+math sequences strings unicode.case urls words ;
 IN: persistency
 
 TUPLE: persistent id ;
@@ -13,7 +12,7 @@ TUPLE: persistent id ;
 : remove-types ( table -- table' ) [ dup array? [ first ] when ] map ;
 
 SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ remove-types define-tuple-class ]
-   [ nip [ dup unparse >upper ] [ add-types ] bi* define-persistent ] 3bi ;
+   [ nip [ dup name>> >upper ] [ add-types ] bi* define-persistent ] 3bi ;
 
 : define-db ( database class -- ) swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
 
diff --git a/extra/ui/frp/gadgets/gadgets.factor b/extra/ui/frp/gadgets/gadgets.factor
index db693e350c..a1287c7363 100644
--- a/extra/ui/frp/gadgets/gadgets.factor
+++ b/extra/ui/frp/gadgets/gadgets.factor
@@ -1,6 +1,6 @@
-USING: accessors arrays kernel models monads sequences
+USING: accessors assocs arrays kernel models monads sequences
 ui.frp.signals ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.buttons.private ui.gadgets.editors
+ui.gadgets.buttons.private ui.gadgets.editors words images.loader
 ui.gadgets.scrollers ui.gadgets.tables ui.images vocabs.parser lexer ;
 IN: ui.frp.gadgets
 
@@ -52,10 +52,11 @@ M: frp-field model-changed 2dup frp-model>> =
 : <frp-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
     f <model> >>model ;
 
-: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> ;
-SYNTAX: IMG-FRP-BTN: image-prep [ <frp-button> ] curry over push-all ;
+: image-prep ( -- quot ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround [ <image-name> ] [ load-image ] [ ] tri
+    [ \ cached-image "memoize" word-prop set-at ] 3curry ;
+SYNTAX: IMG-FRP-BTN: image-prep [ <frp-button> ] append over push-all ;
 
-SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] append over push-all ;
 
 GENERIC: output-model ( gadget -- model )
 M: gadget output-model model>> ;
@@ -75,4 +76,6 @@ 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 ; 
\ No newline at end of file
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ; 
+
+! Make sure prop removal really destroys normal db code
\ No newline at end of file
diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor
index 88443dc479..c3c32cd76f 100644
--- a/extra/ui/frp/layout/layout.factor
+++ b/extra/ui/frp/layout/layout.factor
@@ -21,8 +21,8 @@ TUPLE: placeholder < gadget members ;
 ! Just take the previous mentioned placeholder and use it
 ! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
 DEFER: with-interface
-: insertion-quot ( quot -- quot' ) make:building get [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
-    swap '[ [ _ , @ ] with-interface ] ;
+: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
+    swap '[ [ _ , @ ] with-interface ] ] when* ;
 
 SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
 SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
@@ -71,4 +71,7 @@ M: model (insert-item) parent>> dup book? [ "No models in books" throw ]
 
 : with-interface ( quot -- ) make* [ insert-items ] with-scope ; inline
 
-M: model >>= [ swap insertion-quot <action> ] curry ;
\ No newline at end of file
+M: model >>= [ swap insertion-quot <action> ] curry ;
+M: model fmap insertion-quot <mapped> ;
+M: model $> insertion-quot side-effect-model new-mapped-model ;
+M: model <$ insertion-quot quot-model new-mapped-model ;
\ No newline at end of file
diff --git a/extra/ui/frp/signals/signals.factor b/extra/ui/frp/signals/signals.factor
index 9ba2fc6cd2..681ffafeae 100644
--- a/extra/ui/frp/signals/signals.factor
+++ b/extra/ui/frp/signals/signals.factor
@@ -71,11 +71,8 @@ M: mapped-model (model-changed)
 TUPLE: side-effect-model < mapped-model ;
 M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
 
-: $> ( model quot -- signal ) side-effect-model new-mapped-model ;
-
 TUPLE: quot-model < mapped-model ;
 M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
-M: model <$ quot-model new-mapped-model ;
 
 TUPLE: action-value < basic-model parent ;
 : <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
@@ -105,5 +102,4 @@ M: (frp-when) (model-changed) [ quot>> ] 2keep
 : with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
 
 USE: ui.frp.signals.templates
-M: model fmap <mapped> ;
 << { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor
index 427c423ea5..dc81aff15e 100644
--- a/extra/ui/gadgets/alerts/alerts.factor
+++ b/extra/ui/gadgets/alerts/alerts.factor
@@ -1,4 +1,4 @@
-USING: accessors models macros generalizations kernel
+USING: accessors models monads macros generalizations kernel
 ui ui.frp.gadgets ui.frp.signals ui.frp.layout ui.gadgets
 ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
 ui.gadgets.packs locals sequences fonts io.styles
-- 
2.34.1