steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui.frp uses placeholders for templating

db4
Sam Anklesaria 2009-06-10 16:15:02 -05:00
parent 1aca6455de
commit 5f3ca1072b
7 changed files with 48 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
core/sequences/sequences.factor
View File

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

4
extra/closures/closures.factor
View File

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

20
extra/persistency/persistency.factor
View File

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

9
extra/ui/frp/gadgets/gadgets.factor
View File

@ -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 ) "" <model> <frp-editor> ;
: <frp-editor*> ( -- editor ) f <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>> ;

60
extra/ui/frp/layout/layout.factor
View File

@ -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> 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
: 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 <layout> ] 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
: <box> ( gadgets type -- track )
[ t make-layout ] dip <track>
swap [ insert-layout ] each
handle-words
swap [ add-layout ] each
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
swap [ no-models ] unless-empty ; inline
: <frp-book*> ( quot -- book ) f make-layout f <book> handle-words
swap [ no-models ] unless-empty ; inline
: make-book ( models gadgets model -- book ) <book> swap [ no-models-in-books ] unless-empty ;
: <frp-book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
: <frp-book*> ( 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 <layout> ] 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 <layout> ] 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
: with-interface ( quot: ( -- gadget ) -- gadget ) { } make insert-items ; inline

6
extra/ui/frp/signals/signals.factor
View File

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

8
extra/ui/gadgets/alerts/alerts.factor
View File

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