From 5f3ca1072bb8d69db91a53b01d2ddf810bd9fe1f Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Wed, 10 Jun 2009 16:15:02 -0500 Subject: [PATCH] ui.frp uses placeholders for templating --- core/sequences/sequences.factor | 3 +- extra/closures/closures.factor | 4 +- extra/persistency/persistency.factor | 20 ++------- extra/ui/frp/gadgets/gadgets.factor | 9 ++-- extra/ui/frp/layout/layout.factor | 60 +++++++++++++-------------- extra/ui/frp/signals/signals.factor | 6 ++- extra/ui/gadgets/alerts/alerts.factor | 8 ++-- 7 files changed, 48 insertions(+), 62 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 20a94f411a..5c27079b45 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -941,4 +941,5 @@ PRIVATE> [ list rest identity quot reduce-r list first quot call ] if ; inline recursive -:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ; \ No newline at end of file +:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ; +: (head-slice) ( seq n -- seq' ) over length over < [ drop ] [ head-slice ] if ; \ No newline at end of file diff --git a/extra/closures/closures.factor b/extra/closures/closures.factor index eb5a293fed..79fcf7564e 100644 --- a/extra/closures/closures.factor +++ b/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 ; diff --git a/extra/persistency/persistency.factor b/extra/persistency/persistency.factor index d8bf0e9806..e56a81fd7c 100644 --- a/extra/persistency/persistency.factor +++ b/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 ) { - { 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 ; +: add-types ( table -- table' ) [ dup array? [ first ] when dup >upper FACTOR-BLOB 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 diff --git a/extra/ui/frp/gadgets/gadgets.factor b/extra/ui/frp/gadgets/gadgets.factor index 9e0776752f..31a8364696 100644 --- a/extra/ui/frp/gadgets/gadgets.factor +++ b/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 "" ; inline ! pattern for editors, labels -: ( -- field ) "" ; +: ( -- field ) f ; : ( model -- field ) "" ; +: ( -- field ) "" ; : ( model -- gadget ) frp-field [ ] dip new-border dup gadget-child >>editor field-theme swap >>frp-model { 1 0 } >>align ; -: ( model -- editor ) "" ; -: ( -- editor ) "" ; +: ( -- editor ) f ; +: ( -- field ) "" ; +: ( model -- field ) "" ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor index b5893c7aa3..6da8be3a8d 100644 --- a/extra/ui/frp/layout/layout.factor +++ b/extra/ui/frp/layout/layout.factor @@ -1,11 +1,18 @@ -USING: accessors assocs arrays fry kernel lexer make math math.parser -models models.product namespaces parser sequences -ui.frp.gadgets ui.gadgets ui.gadgets.books ui.gadgets.tracks -words tools.continuations ; +USING: accessors fry kernel lexer make math.parser models +models.product namespaces parser sequences ui.frp.gadgets +ui.gadgets ui.gadgets.books ui.gadgets.tracks vectors words ; +QUALIFIED: make IN: ui.frp.layout TUPLE: layout gadget size ; C: 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 [ , ] curry over push-all ; SYNTAX: ->% scan string>number '[ [ _ , ] [ output-model ] bi ] over push-all ; @@ -16,46 +23,37 @@ M: model -> dup , ; : ( -- ) 1 , ; -SYMBOL: wordnames -: insert-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline +: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline : layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap [ [ dup layout? [ f ] unless ] map ] when ; -: make-layout ( building sized? -- models words layouts ) [ swap layouts ] curry - [ { } make [ [ model? ] filter ] [ [ word? ] filter ] ] dip tri ; inline -: handle-words ( words gadget -- gadget ) tuck - [ [ swap 2array ] curry wordnames get swap change-at ] curry each ; +: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry + [ { } make [ [ model? ] filter ] ] dip bi ; inline : ( gadgets type -- track ) [ t make-layout ] dip - swap [ insert-layout ] each - handle-words + swap [ add-layout ] each swap [ >>model ] unless-empty ; inline : ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline -: ( quot: ( -- model ) -- book ) f make-layout roll dup activate-model handle-words - swap [ no-models ] unless-empty ; inline -: ( quot -- book ) f make-layout f handle-words - swap [ no-models ] unless-empty ; inline +: make-book ( models gadgets model -- book ) swap [ no-models-in-books ] unless-empty ; +: ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline +: ( quot -- book ) f make-layout f make-book ; inline -SYNTAX: $ CREATE-WORD dup [ , ] curry (( -- )) define-declared "$" expect - word [ [ building get length swap wordnames get set-at ] [ , ] bi ] curry over push-all ; +SYNTAX: $ CREATE-WORD placeholder new + [ [ , ] 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 ] - [ [ f ] dip insert-item ] if ; -M: layout insert-item first2 spin [ insert-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ; -M: model insert-item dup first book? [ no-models ] +M: gadget insert-item dup parent>> track? [ [ f ] dip insert-item ] + [ insertion-point [ add-gadget ] keep insert-gadget ] if ; +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-in-books ] [ first model>> swap add-connection ] if ; -: insert-items ( makelist -- ) f swap [ dup word? - [ nip ] [ - over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi - ] if ] each drop ; +: insert-items ( makelist -- ) f swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ; -: with-interface ( quot: ( -- gadget ) -- gadget ) H{ } clone wordnames - [ { } make insert-items ] with-variable ; inline - -! while children are changed, sizes aren't \ No newline at end of file +: with-interface ( quot: ( -- gadget ) -- gadget ) { } make insert-items ; inline \ No newline at end of file diff --git a/extra/ui/frp/signals/signals.factor b/extra/ui/frp/signals/signals.factor index 63a5f9c1f1..61604a0b47 100644 --- a/extra/ui/frp/signals/signals.factor +++ b/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 ; : ( signal1 signal2 -- signal' ) swap [ 2array switch-model ] 2keep - [ >>original ] [ >>switcher ] bi* ; + [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ; M: switch-model model-activated [ original>> ] keep model-changed ; : >behavior ( event -- behavior ) t ; @@ -65,6 +66,7 @@ M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep val [ swap add-connection ] 2keep model-changed ; : ( model quot -- action-signal ) [ 1array action ] dip >>quot dup f >>value value>> ; ( models -- product ) | ; GENERIC: models-changed ( product -- ) @@ -83,4 +85,4 @@ TUPLE: & < | ; : <&> ( models -- product ) & ; M: & models-changed dependencies>> [ f swap (>>value) ] each ; PRIVATE> -FMAPS: $> <$ fmap FOR & | ; \ No newline at end of file +FMAPS: $> <$ fmap FOR & | product ; \ No newline at end of file diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor index abebf458b4..427c423ea5 100644 --- a/extra/ui/gadgets/alerts/alerts.factor +++ b/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