classes.tuple classes.tuple.parser combinators effects
effects.parser fry generic generic.parser generic.standard
interpolate io.streams.string kernel lexer locals.parser
-locals.rewrite.closures locals.types make namespaces parser
-quotations sequences vocabs.parser words words.symbol ;
+locals.rewrite.closures locals.types make macros namespaces
+parser quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
complete-effect parsed
\ define-simple-generic* parsed ;
+SYNTAX: `MACRO:
+ scan-param parsed
+ parse-declared*
+ \ define-macro parsed ;
+
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
+ { "MACRO:" POSTPONE: `MACRO: }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+Inverses of Common Words on Vectors
--- /dev/null
+USING: generalizations inverse kernel locals sequences vectors ;
+IN: inverse.vectors
+: assure-vector ( vector -- vector )
+ dup vector? assure ; inline
+
+: undo-nvector ( array n -- ... )
+ [ assure-vector ] dip
+ firstn ; inline
+
+\ 1vector [ 1 undo-nvector ] define-inverse
+
+\ peek [ 1vector ] define-inverse
+
+! if is too general to undo, but its derivatives aren't
+
+:: undo-if-empty ( result a b -- seq )
+ a call( -- b ) result = [ V{ } clone ] [ result b [undo] call( a -- b ) ] if ;
+
+:: undo-if* ( result a b -- boolean )
+ b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ;
+
+\ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse
+
+\ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse
[ ]
} cond
-: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
+: run-desc ( desc -- result ) utf8 [ contents [ but-last ] [ f ] if* ] with-process-reader ;
--- /dev/null
+USING: accessors models models.arrow inverse inverse.vectors kernel ;
+IN: models.illusion
+
+TUPLE: illusion < arrow ;
+
+: <illusion> ( model quot -- illusion )
+ illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
+ swap >>quot over >>model [ add-dependency ] keep dup activate-model ;
+
+: backtalk ( value object -- )
+ [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
+
+M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
--- /dev/null
+Two Way Arrows
\ No newline at end of file
--- /dev/null
+USING: functors kernel lexer sequences vocabs.parser ;
+IN: pseudo-slots
+FUNCTOR: make-definitions ( D -- )
+D>> DEFINES ${D}>>
+>>D DEFINES >>${D}
+(>>D) DEFINES (>>${D})
+
+WHERE
+GENERIC: (>>D) ( value object -- )
+GENERIC: D>> ( object -- value )
+: >>D ( object value -- object ) over (>>D) ;
+;FUNCTOR
+
+SYNTAX: PSEUDO-SLOTS: ";" parse-tokens [ make-definitions ] each ;
\ No newline at end of file
$nl
"A few slots in the table gadget concern row selection:"
{ $table
- { { $slot "selected-value" } { " - if set to a model, the currently selected row's value, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
- { { $slot "selected-index" } " - the index of the currently selected row." }
+ { { $slot "selected-values" } { " - if set to a model, an array of the currently selected rows' values, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
+ { { $slot "selected-indices" } " - the indices of the currently selected rows." }
{ { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } }
+ { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } }
+
}
"Some words for row selection:"
-{ $subsection selected-row }
-{ $subsection (selected-row) } ;
+{ $subsection selected-rows }
+{ $subsection (selected-rows) } ;
ARTICLE: "ui.gadgets.tables.actions" "Table row actions"
"When the user double-clicks on a row, or presses " { $command table "row" row-action } " while a row is selected, optional action and hook quotations are invoked. The action receives the row value and the hook receives the table gadget itself. These quotations are stored in the " { $slot "action" } " and " { $snippet "hook" } " slots of a table, respectively."
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays colors colors.constants fry kernel math
-math.functions math.rectangles math.order math.vectors namespaces
-opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
-ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-models math.ranges combinators
-combinators.short-circuit fonts locals strings ;
+math.functions math.ranges math.rectangles math.order math.vectors
+models.illusion namespaces opengl pseudo-slots sequences ui.gadgets
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
+ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images
+ui.gadgets.menus ui.gadgets.line-support math.rectangles models
+math.ranges sequences combinators combinators.short-circuit
+fonts locals strings vectors ;
IN: ui.gadgets.tables
! Row rendererer protocol
{ mouse-color initial: COLOR: black }
column-line-color
selection-required?
-selected-index selected-value
+selected-indices selected-values
+selected-indices*
mouse-index
{ takes-focus? initial: t }
-focused? ;
+focused?
+multiple-selection? ;
+
+: in>out ( vector -- val/f ) [ f ] [ peek ] if-empty ;
+: out>in ( val/f -- vector ) [ 1vector ] [ V{ } clone ] if* ;
+IN: accessors
+PSEUDO-SLOTS: selected-value selected-index selected-index* ;
+M: table selected-value>> selected-values>> [ in>out ] <illusion> ;
+M: table (>>selected-value) [ [ out>in ] <illusion> ] dip (>>selected-values) ;
+M: table selected-index>> selected-indices>> in>out ;
+M: table (>>selected-index) [ out>in ] dip (>>selected-indices) ;
+M: table selected-index*>> selected-indices*>> [ in>out ] <illusion> ;
+M: table (>>selected-index*) [ [ out>in ] <illusion> ] dip (>>selected-indices*) ;
+
+IN: ui.gadgets.tables
+: push-selected-index ( table n -- table ) 2dup swap selected-indices>> index [ drop ] [ over selected-indices>> push ] if ;
: new-table ( rows renderer class -- table )
new-line-gadget
swap >>renderer
swap >>model
- f <model> >>selected-value
+ V{ } clone >>selected-indices
+ V{ } clone <model> >>selected-values
+ V{ } clone <model> >>selected-indices*
sans-serif-font >>font
focus-border-color >>focus-border-color
transparent >>column-line-color ; inline
: row-bounds ( table row -- loc dim )
row-rect rect-bounds ; inline
-: draw-selected-row ( table -- )
+: draw-selected-rows ( table -- )
{
- { [ dup selected-index>> not ] [ drop ] }
+ { [ dup selected-indices>> empty? ] [ drop ] }
[
- [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
- row-bounds gl-fill-rect
+ [ selected-indices>> ] [ selection-color>> gl-color ] [ ] tri
+ [ swap row-bounds gl-fill-rect ] curry each
]
} cond ;
dup renderer>> column-alignment
[ ] [ column-widths>> length 0 <repetition> ] ?if ;
-:: row-font ( row index table -- font )
+:: row-font ( row ind table -- font )
table font>> clone
row table renderer>> row-color [ >>foreground ] when*
- index table selected-index>> = [ table selection-color>> >>background ] when ;
+ ind table selected-indices>> index [ table selection-color>> >>background ] when ;
: draw-columns ( columns widths alignment font gap -- )
'[ [ _ ] 3dip _ draw-column ] 3each ;
dup control-value empty? [ drop ] [
dup line-height \ line-height [
{
- [ draw-selected-row ]
+ [ draw-selected-rows ]
[ draw-lines ]
[ draw-column-lines ]
[ draw-focused-row ]
PRIVATE>
-: (selected-row) ( table -- value/f ? )
- [ selected-index>> ] keep nth-row ;
+: (selected-rows) ( table -- {row} )
+ [ selected-indices>> ] keep
+ [ nth-row [ 1vector ] [ drop V{ } clone ] if ] curry map concat ;
-: selected-row ( table -- value/f ? )
- [ (selected-row) ] keep
- swap [ renderer>> row-value t ] [ 2drop f f ] if ;
+: selected-rows ( table -- {value} )
+ [ (selected-rows) ] [ renderer>> ] bi [ row-value ] curry map ;
+
+: multiple>single ( values -- value/f ? ) [ f f ] [ peek t ] if-empty ;
+: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
+: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
<PRIVATE
-: update-selected-value ( table -- )
- [ selected-row drop ] [ selected-value>> ] bi set-model ;
+: update-selected-values ( table -- )
+ [ [ selected-rows ] [ selected-values>> ] bi set-model ]
+ [ [ selected-indices>> ] [ selected-indices*>> ] bi set-model ] bi ;
: show-row-summary ( table n -- )
over nth-row
: find-row-index ( value table -- n/f )
[ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
-: initial-selected-index ( table -- n/f )
+: initial-selected-indices ( table -- {n}/f )
{
[ model>> value>> empty? not ]
[ selection-required?>> ]
- [ drop 0 ]
+ [ drop V{ 0 } clone ]
} 1&& ;
-: (update-selected-index) ( table -- n/f )
- [ selected-value>> value>> ] keep over
- [ find-row-index ] [ 2drop f ] if ;
+: (update-selected-indices) ( table -- {n}/f )
+ [ selected-values>> value>> ] keep
+ [ find-row-index ] curry map [ ] filter [ f ] when-empty ;
-: update-selected-index ( table -- n/f )
+: update-selected-indices ( table -- {n}/f )
{
- [ (update-selected-index) ]
- [ initial-selected-index ]
+ [ (update-selected-indices) ]
+ [ initial-selected-indices ]
} 1|| ;
M: table model-changed
- nip dup update-selected-index {
- [ >>selected-index f >>mouse-index drop ]
- [ show-row-summary ]
- [ drop update-selected-value ]
+ nip dup update-selected-indices [ V{ } clone ] unless* {
+ [ >>selected-indices f >>mouse-index drop ]
+ [ [ f ] [ peek ] if-empty show-row-summary ]
+ [ drop update-selected-values ]
[ drop relayout ]
} 2cleave ;
: thin-row-rect ( table row -- rect )
row-rect [ { 0 1 } v* ] change-dim ;
+: scroll-to-row ( table n -- )
+ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
+
+: add-selected-row ( table n -- )
+ [ scroll-to-row ]
+ [ push-selected-index relayout-1 ] 2bi ;
+
: (select-row) ( table n -- )
- [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
+ [ scroll-to-row ]
[ >>selected-index relayout-1 ]
2bi ;
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
-: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+: if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
[ [ mouse-row ] keep 2dup valid-line? ]
[ ] [ '[ nip @ ] ] tri* if ; inline
-: table-button-down ( table -- )
- dup takes-focus?>> [ dup request-focus ] when
- [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
+: (table-button-down) ( quot table -- )
+ dup takes-focus?>> [ dup request-focus ] when swap
+ '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
+
+: table-button-down ( table -- ) [ (select-row) ] swap (table-button-down) ;
+: continued-button-down ( table -- ) dup multiple-selection?>> [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
+: thru-button-down ( table -- ) dup multiple-selection?>> [
+ [ 2dup over selected-index>> (a,b) swap
+ [ swap push-selected-index drop ] curry each add-selected-row ]
+ swap (table-button-down) ] [ table-button-down ] if ;
PRIVATE>
<PRIVATE
: table-button-up ( table -- )
- dup row-action? [ row-action ] [ update-selected-value ] if ;
+ dup row-action? [ row-action ] [ update-selected-values ] if ;
PRIVATE>
: select-row ( table n -- )
over validate-line
[ (select-row) ]
- [ drop update-selected-value ]
+ [ drop update-selected-values ]
[ show-row-summary ]
2tri ;
{ mouse-enter show-mouse-help }
{ mouse-leave hide-mouse-help }
{ motion show-mouse-help }
- { T{ button-down } table-button-down }
+ { T{ button-down f { S+ } 1 } thru-button-down }
+ { T{ button-down f { A+ } 1 } continued-button-down }
{ T{ button-up } table-button-up }
+ { T{ button-up f { S+ } } table-button-up }
+ { T{ button-down } table-button-down }
{ gain-focus focus-table }
{ lose-focus unfocus-table }
{ T{ drag } table-button-down }
! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel kernel.private slots.private math
+USING: accessors kernel kernel.private locals slots.private math
math.private math.order ;
IN: sequences
[ array-flip ] [ generic-flip ] if
] [ generic-flip ] if
] unless ;
+
+: reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
+
+:: reduce-r
+ ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+ list empty?
+ [ identity ]
+ [ 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
combinators vectors splitting continuations math
parser.notes ;
IN: vocabs.parser
-
+
ERROR: no-word-error name ;
: word-restarts ( possibilities -- restarts )
word-restarts
swap "Defer word in current vocabulary" swap 2array
suffix ;
-
+
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
: search ( name -- word/f )
- manifest get search-manifest ;
+ manifest get search-manifest ;
\ No newline at end of file
--- /dev/null
+USING: fry namespaces kernel sequences parser ;
+IN: closures
+: delayed-bind ( quot -- quot' ) '[ namestack [ set-namestack @ ] curry ] ;
+SYNTAX: C[ parse-quotation delayed-bind over push-all ;
USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals namespaces prettyprint sequences
-ui.frp vectors ;
+io.pathnames kernel locals sequences
+ui.frp vectors make strings ;
IN: file-trees
-TUPLE: tree node children ;
+TUPLE: walkable-vector vector father ;
+CONSULT: sequence-protocol walkable-vector vector>> ;
+
+M: walkable-vector set-nth [ vector>> set-nth ] 3keep nip
+ father>> swap children>> vector>> push ;
+
+TUPLE: tree node comment children ;
CONSULT: sequence-protocol tree children>> ;
-: <tree> ( start -- tree ) V{ } clone
- [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+: file? ( tree -- ? ) children>> [ node>> ".." = not ] filter empty? ;
+
+: <dir-tree> ( {start,comment} -- tree ) first2 walkable-vector new vector new >>vector
+ [ tree boa dup children>> ] [ ".." -rot tree boa ] 2bi swap (>>father) ;
DEFER: (tree-insert)
-: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
+: tree-insert ( path tree -- ) [ unclip <dir-tree> ] [ children>> ] bi* (tree-insert) ;
:: (tree-insert) ( path-rest path-head tree-children -- )
tree-children [ node>> path-head node>> = ] find nip
[ path-rest swap tree-insert ]
path-head tree-children push
path-rest [ path-head tree-insert ] unless-empty
] if* ;
-: create-tree ( file-list -- tree ) [ path-components ] map
- t <tree> [ [ tree-insert ] curry each ] keep ;
+
+: add-paths ( pathseq -- {{name,path}} )
+ "" [ [ "/" glue dup ] keep swap 2array , ] [ reduce drop ] f make ;
+
+: go-to-path ( path tree -- tree' ) over empty? [ nip ]
+ [ [ unclip ] [ children>> ] bi* swap [ swap node>> = ] curry find nip go-to-path ] if ;
+
+: find-root ( pathseq -- root ) dup flip
+ [ [ dupd = [ ] [ drop f ] if ] reduce1 ] find-last drop
+ [ first ] dip head-slice >string path-components ;
+
+: create-tree ( file-list -- tree ) [ find-root ]
+ [ [ path-components add-paths ] map { "/" "/" } <dir-tree> [ [ tree-insert ] curry each ] keep ] bi
+ go-to-path ;
: <dir-table> ( tree-model -- table )
<frp-list*> [ node>> 1array ] >>quot
- [ selected-value>> <switch> ]
+ [ selected-value>> [ file? not ] <filter> <switch> ]
[ swap >>model ] bi ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: arrays vectors combinators effects kernel math sequences splitting
+strings.parser parser ;
+IN: fries
+SYMBOL: _
+: str-fry ( str on -- quot ) split
+ [ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+: gen-fry ( str on -- quot ) split
+ [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+
+SYNTAX: i" parse-string rest "_" str-fry over push-all ;
+SYNTAX: i{ \ } parse-until >array { _ } gen-fry over push-all ;
+SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry over push-all ;
--- /dev/null
+Generalized Frying
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: modules.rpc-server vocabs ;
+IN: modules.remote-loading mem-service
+
+: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
--- /dev/null
+required for listeners allowing remote loading of modules
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors assocs continuations effects io
+io.encodings.binary io.servers.connection kernel
+memoize namespaces parser sets sequences serialize
+threads vocabs vocabs.parser words ;
+
+IN: modules.rpc-server
+
+SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
+
+: do-rpc ( args word -- bytes )
+ [ execute ] curry with-datastack object>bytes ; inline
+
+MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
+
+: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
+ swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- ) deserialize dup serving-vocabs get-global index
+ [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- ) [
+ <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
+ start-server ] in-thread ;
+
+: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
+ current-vocab serving-vocabs get-global adjoin
+ "get-words" create-in
+ in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+ (( -- words )) define-inline ;
+
+SYNTAX: service \ do-rpc "executer" set (service) ;
+SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
+
+load-vocab-hook [
+ [ dup words>> values
+ \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
+append ] change-global
\ No newline at end of file
--- /dev/null
+remote procedure call server
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.units combinators fry generalizations io
+io.encodings.binary io.sockets kernel namespaces
+parser sequences serialize vocabs vocabs.parser words ;
+IN: modules.rpc
+
+DEFER: get-words
+
+: with-in-vocab ( vocab quot -- vocab ) over
+ [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
+
+: remote-quot ( addrspec vocabspec effect str -- quot )
+ '[ _ 5000 <inet> binary
+ [
+ _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
+ ] with-client
+ ] ;
+
+: define-remote ( addrspec vocabspec effect str -- ) [
+ [ remote-quot ] 2keep create-in -rot define-declared word make-inline
+ ] with-compilation-unit ;
+
+: remote-vocab ( addrspec vocabspec -- vocab )
+ dup "-remote" append [
+ [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
+ [ rot first2 swap define-remote ] 2curry each
+ ] with-in-vocab ;
\ No newline at end of file
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+module pushing in remote-loading listeners
\ No newline at end of file
--- /dev/null
+USING: assocs modules.rpc-server vocabs
+modules.remote-loading words ;
+IN: modules.uploads service
+
+: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+improved module import syntax
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+USING: modules.rpc-server io.servers.connection ;
+IN: modules.test-server service
+: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
--- /dev/null
+USING: modules.using ;
+IN: modules.using.tests
+USING: tools.test localhost::modules.test-server ;
+[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
--- /dev/null
+USING: modules.using modules.rpc-server help.syntax help.markup strings ;
+IN: modules
+
+HELP: service
+{ $syntax "IN: module service" }
+{ $description "Starts a server for requests for remote procedure calls." } ;
+
+ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
+"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
+
+HELP: USING:
+{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
+{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
+{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
--- /dev/null
+USING: assocs kernel modules.remote-loading modules.rpc
+namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
+strings ;
+IN: modules.using
+
+: >qualified ( vocab prefix -- assoc )
+ [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
+
+: >partial-vocab ( words assoc -- assoc )
+ [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+
+: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
+
+: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+plain = tokenpart => [[ load-vocab ]]
+module = rpc | remote | plain
+;EBNF
+
+ON-BNF: USING:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>").
+modspec = sym => [[ modulize ]]
+qualified = modspec sym => [[ first2 >qualified ]]
+unqualified = modspec => [[ vocab-words ]]
+words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
+long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
+short = modspec => [[ use+ ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
--- /dev/null
+USING: accessors assocs kernel lexer locals namespaces sequences
+vocabs vocabs.parser ;
+IN: modules.util
+SYNTAX: EXPORT-FROM: [let | v [ in get ] |
+ v vocab words>> ";" parse-tokens
+ [ load-vocab vocab-words [ clone v >>vocabulary ] assoc-map ] map
+ assoc-combine update ] ;
\ No newline at end of file
M: monad fail monad-of fail ;
: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
+: bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
:: lift-m2 ( m1 m2 f monad -- m3 )
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: combinators effects kernel math sequences splitting
-strings.parser ;
-IN: str-fry
-: str-fry ( str -- quot ) "_" split
- [ unclip [ [ rot glue ] reduce ] 2curry ]
- [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
-SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file
+++ /dev/null
-String Frying
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax models monads sequences
-ui.gadgets.buttons ui.gadgets.tracks ;
-IN: ui.frp
-
-! Layout utilities
-
-HELP: ,
-{ $values { "uiitem" "a gadget or model" } }
-{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
-HELP: ->
-{ $values { "uiitem" "a gadget or model" } { "model" model } }
-{ $description "Like " { $link , } "but passes its model on for further use." } ;
-HELP: <hbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
-HELP: <vbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
-
-! Gadgets
-HELP: <frp-button>
-{ $values { "text" "the button's label" } { "button" button } }
-{ $description "Creates an button whose model updates on clicks" } ;
-
-HELP: <merge>
-{ $values { "models" "a list of models" } { "model" merge-model } }
-{ $description "Creates a model that merges the updates of others" } ;
-
-HELP: <filter>
-{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
-{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
-
-HELP: <fold>
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
-{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-
-HELP: <switch>
-{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
-{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
-
-ARTICLE: { "frp" "instances" } "FRP Instances"
-"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
-"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
-
-USING: accessors arrays colors fonts kernel models
-models.product monads sequences ui.gadgets ui.gadgets.buttons
-ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
-ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
-QUALIFIED: make
+USING: modules.util ui.frp.functors monads ;
IN: ui.frp
-
-! Gadgets
-: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
-TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
-M: frp-table column-titles column-titles>> ;
-M: frp-table column-alignment column-alignment>> ;
-M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-
-: <frp-table> ( model -- table )
- frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
- f <model> >>selected-value sans-serif-font >>font
- focus-border-color >>focus-border-color
- transparent >>column-line-color [ ] >>val-quot ;
-: <frp-table*> ( -- table ) f <model> <frp-table> ;
-: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
-: <frp-list*> ( -- table ) f <model> <frp-list> ;
-
-: <frp-field> ( -- field ) f <model> <model-field> ;
-
-! Layout utilities
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: frp-table output-model selected-value>> ;
-M: model-field output-model field-model>> ;
-M: scroller output-model children>> first model>> ;
-
-GENERIC: , ( uiitem -- )
-M: gadget , make:, ;
-M: model , activate-model ;
-
-GENERIC: -> ( uiitem -- model )
-M: gadget -> dup make:, output-model ;
-M: model -> dup , ;
-M: table -> dup , selected-value>> ;
-
-: <box> ( gadgets type -- track )
- [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
-: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
-: <hbox> ( gadgets -- track ) horizontal <box> ; inline
-: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
-: <vbox> ( gadgets -- track ) vertical <box> ; inline
-: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
-
-! !!! Model utilities
-TUPLE: multi-model < model ;
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-
-! Events- discrete model utilities
-
-TUPLE: merge-model < multi-model ;
-M: merge-model model-changed [ value>> ] dip set-model ;
-: <merge> ( models -- model ) merge-model <multi-model> ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
- [ set-model ] [ 2drop ] if ;
-: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
-
-! Behaviors - continuous model utilities
-
-TUPLE: fold-model < multi-model oldval quot ;
-M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
- call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
- swap [ >>oldval ] [ >>value ] bi ;
-
-TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model model-changed 2dup switcher>> =
- [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
- [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
- [ >>original ] [ >>switcher ] bi* ;
-
-TUPLE: mapped < model model quot ;
-
-: <mapped> ( model quot -- arrow )
- f mapped new-model
- swap >>quot
- over >>model
- [ add-dependency ] keep ;
-
-M: mapped model-changed
- [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
- set-model ;
-
-! Instances
-M: model fmap <mapped> ;
-
-SINGLETON: gadget-monad
-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
+EXPORT-FROM: ui.frp.signals ui.frp.gadgets ui.frp.instances ui.frp.layout ;
+FMAPS: $> <$ fmap FOR & | ;
\ No newline at end of file
--- /dev/null
+USING: fry functors generalizations kernel macros peg peg-lexer
+sequences ;
+IN: ui.frp.functors
+
+FUNCTOR: fmaps ( W P -- )
+W IS ${W}
+<p> IS <${P}>
+w-n DEFINES ${W}-n-${P}
+w-2 DEFINES 2${W}-${P}
+w-3 DEFINES 3${W}-${P}
+w-4 DEFINES 4${W}-${P}
+WHERE
+MACRO: w-n ( int -- quot ) dup '[ [ _ narray <p> ] dip [ _ firstn ] prepend W ] ;
+: w-2 ( a b quot -- mapped ) 2 w-n ; inline
+: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
+: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
+;FUNCTOR
+
+ON-BNF: FMAPS:
+tokenizer = <foreign factor>
+token = !("FOR"|";").
+middle = "FOR" => [[ drop ignore ]]
+endexpr = ";" => [[ drop ignore ]]
+expr = token* middle token* endexpr => [[ first2 combos [ first2 fmaps ] each ignore ]]
+;ON-BNF
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel models ui.frp.signals ui.gadgets
+ui.gadgets.buttons ui.gadgets.buttons.private
+ui.gadgets.editors ui.gadgets.tables ;
+IN: ui.frp.gadgets
+
+TUPLE: frp-button < button hook ;
+: <frp-button> ( gadget -- button ) [
+ [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
+ t swap set-control-value
+ ] frp-button new-button f <basic> >>model ;
+
+: <frp-bevel-button> ( text -- button ) <frp-button> border-button-theme ;
+
+TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ;
+M: frp-table column-titles column-titles>> ;
+M: frp-table column-alignment column-alignment>> ;
+M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
+ V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices* ;
+: <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
+: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
+: <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+: <frp-field> ( -- field ) "" <model> <model-field> ;
\ No newline at end of file
--- /dev/null
+USING: accessors kernel models monads ui.frp.signals ui.frp.layout ui.gadgets ;
+IN: ui.frp.instances
+
+M: model >>= [ swap <action> ] curry ;
+M: model fmap <mapped> ;
+
+SINGLETON: gadget-monad
+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 ;
--- /dev/null
+USING: accessors fry kernel lexer math.parser models sequences
+ui.frp.signals ui.gadgets ui.gadgets.editors ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ;
+QUALIFIED: make
+IN: ui.frp.layout
+TUPLE: layout gadget width ; C: <layout> layout
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup multiple-selection?>>
+ [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
+ [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
+M: model-field output-model field-model>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+
+GENERIC: , ( uiitem -- )
+M: gadget , f <layout> make:, ;
+M: model , activate-model ;
+
+SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup , output-model ;
+M: model -> dup , ;
+
+: <spacer> ( -- ) <gadget> 1 <layout> make:, ;
+: <box> ( gadgets type -- track )
+ [ { } make:make ] dip <track> swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
+: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <|> ] bi >>model ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel models models.product sequences ;
+IN: ui.frp.signals
+
+TUPLE: multi-model < model ;
+GENERIC: (model-changed) ( model observer -- )
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
+M: multi-model model-activated dup dependencies>> dup length 1 =
+ [ first swap model-changed ] [ 2drop ] if ;
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: <merge> ( models -- model ) basic-model <multi-model> ;
+: <basic> ( value -- model ) basic-model new-model ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+ [ set-model ] [ 2drop ] if ;
+: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model oldval quot ;
+M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
+ call( val oldval -- newval ) ] keep set-model ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
+ swap [ >>oldval ] [ >>value ] bi ;
+
+TUPLE: updater-model < multi-model values updates ;
+M: updater-model (model-changed) tuck updates>> =
+ [ [ values>> value>> ] keep set-model ]
+ [ drop ] if ;
+: <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
+ [ >>values ] [ >>updates ] bi* ;
+
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model (model-changed) 2dup switcher>> =
+ [ [ value>> ] [ t >>on ] bi* set-model ]
+ [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
+: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
+ [ >>original ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: >behavior ( event -- behavior ) t <model> swap <switch> ;
+
+TUPLE: mapped-model < multi-model model quot ;
+: new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
+ <multi-model> swap >>quot swap >>model ;
+: <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
+M: mapped-model (model-changed)
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+TUPLE: side-effect-model < mapped-model ;
+M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
+: $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
+
+TUPLE: quot-model < mapped-model ;
+M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
+: <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
+
+TUPLE: action-value < basic-model parent ;
+: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
+M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
+
+TUPLE: action < multi-model quot ;
+M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
+ [ swap add-connection ] 2keep model-changed ;
+: <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
+
+TUPLE: | < multi-model ;
+: <|> ( models -- product ) | <multi-model> ;
+GENERIC: models-changed ( product -- )
+M: | models-changed drop ;
+M: | model-changed
+ nip
+ dup dependencies>> [ value>> ] all?
+ [ [ dup [ value>> ] product-value >>value notify-connections ] keep models-changed ]
+ [ drop ] if ;
+M: | update-model
+ dup value>> swap [ set-model ] set-product-value ;
+M: | model-activated dup model-changed ;
+
+! Only when everything's true does he make it false
+TUPLE: & < | ;
+: <&> ( models -- product ) & <multi-model> ;
+M: & models-changed dependencies>> [ f swap (>>value) ] each ;
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax models monads sequences
+ui.gadgets.buttons ui.gadgets.tracks ;
+IN: ui.frp
+
+! Layout utilities
+
+HELP: ,
+{ $values { "uiitem" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like " { $link , } "but passes its model on for further use." } ;
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+! Gadgets
+HELP: <frp-button>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose model updates on clicks" } ;
+
+HELP: <merge>
+{ $values { "models" "a list of models" } { "model" basic-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: <filter>
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
+
+HELP: <fold>
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: <switch>
+{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
+{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
+
+ARTICLE: { "frp" "instances" } "FRP Instances"
+"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
+"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
+
-USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
+USING: accessors models macros generalizations kernel ui ui.frp
+ui.gadgets ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
+ui.gadgets.packs locals sequences fonts io.styles wrap.strings ;
+
IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
- "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
\ No newline at end of file
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
+ string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
+ "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
+
+: alert* ( str -- ) [ ] swap alert ;
+
+:: ask-user* ( model string -- model' )
+ [ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
+ fldm [ <frp-field> ->% 1 ]
+ btn [ "okay" <frp-bevel-button> model >>model ] |
+ 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 ,
+ [ [ <frp-bevel-button> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+ { 200 110 } >>pref-dim "" open-window
+ ] dip firstn
+ ] 2curry ;
\ No newline at end of file
USING: accessors arrays kernel math.rectangles models sequences
-ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
+ui.gadgets ui.gadgets.glass ui.gadgets.labels
ui.gadgets.tables ui.gestures ;
IN: ui.gadgets.comboboxes
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: modules.rpc-server vocabs ;
-IN: modules.remote-loading mem-service
-
-: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
+++ /dev/null
-required for listeners allowing remote loading of modules
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: accessors assocs continuations effects io
-io.encodings.binary io.servers.connection kernel
-memoize namespaces parser sets sequences serialize
-threads vocabs vocabs.parser words ;
-
-IN: modules.rpc-server
-
-SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
-
-: do-rpc ( args word -- bytes )
- [ execute ] curry with-datastack object>bytes ; inline
-
-MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
-
-: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
- swap at "executer" get execute( args word -- bytes ) write flush ;
-
-: (serve) ( -- ) deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- ) [
- <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
- start-server ] in-thread ;
-
-: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
- current-vocab serving-vocabs get-global adjoin
- "get-words" create-in
- in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
- (( -- words )) define-inline ;
-
-SYNTAX: service \ do-rpc "executer" set (service) ;
-SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
-
-load-vocab-hook [
- [ dup words>> values
- \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
-append ] change-global
\ No newline at end of file
+++ /dev/null
-remote procedure call server
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: modules.rpc
-ARTICLE: { "modules" "protocol" } "RPC Protocol"
-{ $list
- "Send vocab as string"
- "Send arglist"
- "Send word as string"
- "Receive result list"
-} ;
\ No newline at end of file
+++ /dev/null
-USING: accessors compiler.units combinators fry generalizations io
-io.encodings.binary io.sockets kernel namespaces
-parser sequences serialize vocabs vocabs.parser words ;
-IN: modules.rpc
-
-DEFER: get-words
-
-: remote-quot ( addrspec vocabspec effect str -- quot )
- '[ _ 5000 <inet> binary
- [
- _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
- ] with-client
- ] ;
-
-: define-remote ( addrspec vocabspec effect str -- ) [
- [ remote-quot ] 2keep create-in -rot define-declared word make-inline
- ] with-compilation-unit ;
-
-: with-in ( vocab quot -- vocab ) over
- [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
-
-: remote-vocab ( addrspec vocabspec -- vocab )
- dup "-remote" append [
- [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
- [ rot first2 swap define-remote ] 2curry each
- ] with-in ;
\ No newline at end of file
+++ /dev/null
-remote procedure call client
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-module pushing in remote-loading listeners
\ No newline at end of file
+++ /dev/null
-USING: assocs modules.rpc-server vocabs
-modules.remote-loading words ;
-IN: modules.uploads service
-
-: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-improved module import syntax
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-USING: modules.rpc-server io.servers.connection ;
-IN: modules.test-server service
-: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
+++ /dev/null
-USING: modules.using ;
-IN: modules.using.tests
-USING: tools.test localhost::modules.test-server ;
-[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
+++ /dev/null
-USING: modules.using modules.rpc-server help.syntax help.markup strings ;
-IN: modules
-
-HELP: service
-{ $syntax "IN: module service" }
-{ $description "Starts a server for requests for remote procedure calls." } ;
-
-ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
-"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
-
-HELP: USING:
-{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
-{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
-{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
+++ /dev/null
-USING: assocs kernel modules.remote-loading modules.rpc
-namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
-strings ;
-IN: modules.using
-
-: >qualified ( vocab prefix -- assoc )
- [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
-
-: >partial-vocab ( words assoc -- assoc )
- [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
-
-: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
-
-: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
-
-EBNF: modulize
-tokenpart = (!(':').)+ => [[ >string ]]
-s = ':' => [[ drop ignore ]]
-rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
-remote = tokenpart s tokenpart => [[ first2 remote-load ]]
-plain = tokenpart => [[ load-vocab ]]
-module = rpc | remote | plain
-;EBNF
-
-ON-BNF: USING:
-tokenizer = <foreign factor>
-sym = !(";"|"}"|"=>").
-modspec = sym => [[ modulize ]]
-qualified = modspec sym => [[ first2 >qualified ]]
-unqualified = modspec => [[ vocab-words ]]
-words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
-long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
-short = modspec => [[ use+ ignore ]]
-wordSpec = long | short
-using = wordSpec+ ";" => [[ drop ignore ]]
-;ON-BNF
\ No newline at end of file
projects / factor.git / commitdiff