ui.frp uses placeholders for templating

core/sequences/sequences.factor

@@ -942,3 +942,4 @@ PRIVATE>
     inline recursive
 
 :: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;
+: (head-slice) ( seq n -- seq' ) over length over < [ drop ] [ head-slice ] if ;

extra/closures/closures.factor

@@ -1,9 +1,9 @@
-USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser ;
+USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser hashtables ;
 IN: closures
 SYMBOL: |
 
 ! Selective Binding
-: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip [ _ bind ] curry ] ;
+: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ;
 SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ;
 ! Common ones
 SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ;

extra/persistency/persistency.factor

@@ -5,28 +5,14 @@ tools.continuations ;
 IN: persistency
 
 TUPLE: persistent id ;
-UNION: bool word POSTPONE: f ;
-UNION: short-string string ;
 
-: db-ize ( class -- db-class ) {
+: add-types ( table -- table' ) [ dup array? [ first ] when dup >upper FACTOR-BLOB 3array ] map
-   { bool [ BOOLEAN ] }
-   { short-string [ { VARCHAR 100 } ] }
-   { string [ TEXT ] }
-   { float [ DOUBLE ] }
-   { timestamp [ TIMESTAMP ] }
-   { fixnum [ INTEGER ] }
-   { byte-array [ BLOB ] }
-   { url [ URL ] }
-   [ drop FACTOR-BLOB ]
-} case ;
-
-: add-types ( table -- table' ) [ [ first dup >upper ] [ second db-ize ] bi 3array ] map
     { "id" "ID" +db-assigned-id+ } prefix ;
 
 SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ define-tuple-class ]
    [ nip [ dup unparse >upper ] [ add-types ] bi* define-persistent ] 3bi ;
 
-: define-db ( database class -- ) swap [ [ recreate-table ] with-db ] [ "database" set-word-prop ] 2bi ;
+: define-db ( database class -- ) swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
 
 : query>tuple ( tuple/query -- tuple ) dup query? [ tuple>> ] when ;
 : w/db ( query quot -- ) [ dup query>tuple class "database" word-prop ] dip with-db ; inline

extra/ui/frp/gadgets/gadgets.factor

@@ -37,15 +37,16 @@ M: frp-field ungraft*
 M: frp-field model-changed 2dup frp-model>> =
     [ [ value>> ] [ editor>> ] bi* set-editor-string ]
     [ nip [ editor>> editor-string ] [ frp-model>> ] bi set-model ] if ;
-: after-empty ( model quot -- model' ) fmap "" <model> <switch> ; inline ! pattern for editors, labels
 
-: <frp-field*> ( -- field ) "" <model> <frp-field> ;
+: <frp-field*> ( -- field ) f <model> <frp-field> ;
 : <empty-field> ( model -- field ) "" <model> <switch> <frp-field> ;
+: <empty-field*> ( -- field ) "" <model> <frp-field> ;
 : <frp-editor> ( model -- gadget )
     frp-field [ <multiline-editor> ] dip new-border dup gadget-child >>editor
     field-theme swap >>frp-model { 1 0 } >>align ;
-: <empty-editor> ( model -- editor ) "" <model> <switch> <frp-editor> ;
+: <frp-editor*> ( -- editor ) f <model> <frp-editor> ;
-: <frp-editor*> ( -- editor ) "" <model> <frp-editor> ;
+: <empty-editor*> ( -- field ) "" <model> <frp-editor> ;
+: <empty-editor> ( model -- field ) "" <model> <switch> <frp-editor> ;
 
 GENERIC: output-model ( gadget -- model )
 M: gadget output-model model>> ;

extra/ui/frp/layout/layout.factor

@@ -1,11 +1,18 @@
-USING: accessors assocs arrays fry kernel lexer make math math.parser
+USING: accessors fry kernel lexer make math.parser models
-models models.product namespaces parser sequences
+models.product namespaces parser sequences ui.frp.gadgets
-ui.frp.gadgets ui.gadgets ui.gadgets.books ui.gadgets.tracks
+ui.gadgets ui.gadgets.books ui.gadgets.tracks vectors words ;
-words tools.continuations ;
+QUALIFIED: make
 IN: ui.frp.layout
 
 TUPLE: layout gadget size ; C: <layout> layout
-ERROR: no-models models ;
+TUPLE: placeholder < gadget ;
+ERROR: no-models-in-books models ;
+
+DEFER: insert-item
+HOOK: , building ( uiitem -- )
+M: vector , make:, ;
+M: f , dup placeholder? [ building set ] [ "No location to add UI item" throw ] if ;
+M: placeholder , [ building get insert-item ] keep relayout ;
 
 SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
 SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
@@ -16,46 +23,37 @@ M: model -> dup , ;
 
 : <spacer> ( -- ) <gadget> 1 <layout> , ;
 
-SYMBOL: wordnames
+: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
-: insert-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
 : layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
    [ [ dup layout? [ f <layout> ] unless ] map ] when ;
-: make-layout ( building sized? -- models words layouts ) [ swap layouts ] curry
+: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
-   [ { } make [ [ model? ] filter ] [ [ word? ] filter ] ] dip tri ; inline
+   [ { } make [ [ model? ] filter ] ] dip bi ; inline
-: handle-words ( words gadget -- gadget ) tuck
-   [ [ swap 2array ] curry wordnames get swap change-at ] curry each ;
 : <box> ( gadgets type -- track )
    [ t make-layout ] dip <track>
-   swap [ insert-layout ] each
+   swap [ add-layout ] each
-   handle-words
    swap [ <product> >>model ] unless-empty ; inline
 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
 : <vbox> ( gadgets -- track ) vertical <box> ; inline
 
-: <frp-book> ( quot: ( -- model ) -- book ) f make-layout roll dup activate-model <book> handle-words
+: make-book ( models gadgets model -- book ) <book> swap [ no-models-in-books ] unless-empty ;
-   swap [ no-models ] unless-empty ; inline
+: <frp-book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
-: <frp-book*> ( quot -- book ) f make-layout f <book> handle-words
+: <frp-book*> ( quot -- book ) f make-layout f make-book ; inline
-   swap [ no-models ] unless-empty ; inline
 
-SYNTAX: $ CREATE-WORD dup [ , ] curry (( -- )) define-declared "$" expect
+SYNTAX: $ CREATE-WORD placeholder new
-   word [ [ building get length swap wordnames get set-at ] [ , ] bi ] curry over push-all ;
+    [ [ , ] curry (( -- )) define-declared "$" expect ]
+    [ [ , ] curry ] bi over push-all ;
 
 : insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
 : insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
+: insertion-point ( gadget placeholder -- number parent gadget ) dup parent>> [ children>> index ] keep rot ;
 
 GENERIC# insert-item 1 ( item location -- )
-M: gadget insert-item dup first book? [ first2 spin [ add-gadget ] keep insert-gadget ]
+M: gadget insert-item dup parent>> track? [ [ f <layout> ] dip insert-item ]
-   [ [ f <layout> ] dip insert-item ] if ;
+    [ insertion-point [ add-gadget ] keep insert-gadget ] if ;
-M: layout insert-item first2 spin [ insert-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
+M: layout insert-item insertion-point [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
-M: model insert-item dup first book? [ no-models ]
+M: model insert-item dup first book? [ no-models-in-books ]
    [ first model>> swap add-connection ] if ;
 
-: insert-items ( makelist -- ) f swap [ dup word?
+: insert-items ( makelist -- ) f swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
-   [ nip ] [
-      over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi
-   ] if ] each drop ;
 
-: with-interface ( quot: ( -- gadget ) -- gadget ) H{ } clone wordnames
+: with-interface ( quot: ( -- gadget ) -- gadget ) { } make insert-items ; inline
-   [ { } make insert-items ] with-variable ; inline
-
-! while children are changed, sizes aren't

extra/ui/frp/signals/signals.factor

@@ -1,4 +1,5 @@
 USING: accessors arrays kernel monads models models.product sequences ui.frp.functors ;
+FROM: models.product => product ;
 IN: ui.frp.signals
 
 TUPLE: multi-model < model ;
@@ -36,7 +37,7 @@ M: switch-model model-changed 2dup switcher>> =
    [ [ value>> ] dip over [ t >>on set-model ] [ nip [ original>> ] keep f >>on model-changed ] if ]
    [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
 : <switch> ( signal1 signal2 -- signal' ) swap [ 2array switch-model <multi-model> ] 2keep
-   [ >>original ] [ >>switcher ] bi* ;
+   [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
 M: switch-model model-activated [ original>> ] keep model-changed ;
 : >behavior ( event -- behavior ) t <model> <switch> ;
 
@@ -65,6 +66,7 @@ M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep val
    [ swap add-connection ] 2keep model-changed ;
 : <action> ( model quot -- action-signal ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
 <PRIVATE
+
 TUPLE: | < multi-model ;
 : <|> ( models -- product ) | <multi-model> ;
 GENERIC: models-changed ( product -- )
@@ -83,4 +85,4 @@ TUPLE: & < | ;
 : <&> ( models -- product ) & <multi-model> ;
 M: & models-changed dependencies>> [ f swap (>>value) ] each ;
 PRIVATE>
-FMAPS: $> <$ fmap FOR & | ;
+FMAPS: $> <$ fmap FOR & | product ;

extra/ui/gadgets/alerts/alerts.factor

@@ -1,4 +1,4 @@
-USING: accessors models macros make generalizations kernel
+USING: accessors models 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
@@ -11,16 +11,14 @@ IN: ui.gadgets.alerts
 
 : alert* ( str -- ) [ ] swap alert ;
 
-:: ask-user* ( model string -- model' )
+:: ask-user ( string -- model' )
    [ [let | lbl  [ string <label>  T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
             fldm [ <frp-field*> ->% 1 ]
-            btn  [ "okay" <frp-border-button> model >>model ] |
+            btn  [ "okay" <frp-border-button> ] |
          btn -> [ fldm swap <updates> ]
                 [ [ drop lbl close-window ] $> , ] bi
    ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
 
-: ask-user ( string -- model ) f <model> swap ask-user* ;
-
 MACRO: ask-buttons ( buttons -- quot ) dup length [
       [ swap
          [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,