some non-reflective frp deployment working

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
 

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
+math sequences strings unicode.case urls words ;
-tools.continuations ;
 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 ;
 

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> ;
+: image-prep ( -- quot ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround [ <image-name> ] [ load-image ] [ ] tri
-SYNTAX: IMG-FRP-BTN: image-prep [ <frp-button> ] curry over push-all ;
+    [ \ 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 ; 
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ; 
+
+! Make sure prop removal really destroys normal db code

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*
+: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
-    swap '[ [ _ , @ ] with-interface ] ;
+    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 ;
+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 ;

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 >>

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