Merge branch 'master' of git://github.com/bogiebro/factor

db4
Doug Coleman 2009-05-01 15:57:33 -05:00
commit e5217b928e
6 changed files with 58 additions and 13 deletions

View File

@ -12,6 +12,9 @@ IN: cocoa.dialogs
dup 1 -> setResolvesAliases: dup 1 -> setResolvesAliases:
dup 1 -> setAllowsMultipleSelection: ; dup 1 -> setAllowsMultipleSelection: ;
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
dup 1 -> setCanChooseDirectories: ;
: <NSSavePanel> ( -- panel ) : <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel NSSavePanel -> savePanel
dup 1 -> setCanChooseFiles: dup 1 -> setCanChooseFiles:
@ -21,10 +24,12 @@ IN: cocoa.dialogs
CONSTANT: NSOKButton 1 CONSTANT: NSOKButton 1
CONSTANT: NSCancelButton 0 CONSTANT: NSCancelButton 0
: open-panel ( -- paths ) : (open-panel) ( panel -- paths )
<NSOpenPanel>
dup -> runModal NSOKButton = dup -> runModal NSOKButton =
[ -> filenames CF>string-array ] [ drop f ] if ; [ -> filenames CF>string-array ] [ drop f ] if ;
: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
: split-path ( path -- dir file ) : split-path ( path -- dir file )
"/" split1-last [ <NSString> ] bi@ ; "/" split1-last [ <NSString> ] bi@ ;

View File

@ -3,9 +3,9 @@
USING: system kernel namespaces strings hashtables sequences USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings io io.encodings.ascii io.backend io.timeouts io.pipes
io.streams.duplex io.ports debugger prettyprint summary io.pipes.private io.encodings io.streams.duplex io.ports
calendar ; debugger prettyprint summary calendar ;
IN: io.launcher IN: io.launcher
TUPLE: process < identity-tuple TUPLE: process < identity-tuple
@ -265,3 +265,5 @@ M: object run-pipeline-element
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] } { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ] [ ]
} cond } cond
: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;

View File

@ -0,0 +1,4 @@
USING: kernel file-trees ;
IN: file-trees.tests
{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop

View File

@ -0,0 +1,23 @@
USING: accessors delegate delegate.protocols io.pathnames
kernel locals namespaces sequences vectors
tools.annotations prettyprint ;
IN: file-trees
TUPLE: tree node children ;
CONSULT: sequence-protocol tree children>> [ node>> ] map ;
: <tree> ( start -- tree ) V{ } clone
[ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
DEFER: (tree-insert)
: tree-insert ( path tree -- ) [ unclip <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 ;

View File

@ -1,36 +1,46 @@
USING: ui.frp help.syntax help.markup monads sequences ; USING: help.markup help.syntax models monads sequences
ui.gadgets.buttons ui.gadgets.tracks ;
IN: ui.frp IN: ui.frp
! Layout utilities ! Layout utilities
HELP: , HELP: ,
{ $values { "uiitem" "a gadget or model" } }
{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ; { $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
HELP: -> HELP: ->
{ $values { "uiitem" "a gadget or model" } { "model" model } }
{ $description "Like " { $link , } "but passes its model on for further use." } ; { $description "Like " { $link , } "but passes its model on for further use." } ;
HELP: <hbox> HELP: <hbox>
{ $values { "gadgets" "a list of gadgets" } { "track" track } }
{ $syntax "[ gadget , gadget , ... ] <hbox>" } { $syntax "[ gadget , gadget , ... ] <hbox>" }
{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ; { $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
HELP: <vbox> HELP: <vbox>
{ $values { "gadgets" "a list of gadgets" } { "track" track } }
{ $syntax "[ gadget , gadget , ... ] <hbox>" } { $syntax "[ gadget , gadget , ... ] <hbox>" }
{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ; { $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
! Gadgets ! Gadgets
HELP: <frp-button> HELP: <frp-button>
{ $values { "text" "the button's label" } { "button" button } }
{ $description "Creates an button whose model updates on clicks" } ; { $description "Creates an button whose model updates on clicks" } ;
HELP: <merge> HELP: <merge>
{ $description "Creates a model that merges the updates of two others" } ; { $values { "models" "a list of models" } { "model" merge-model } }
{ $description "Creates a model that merges the updates of others" } ;
HELP: <filter> 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" } ; { $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
HELP: <fold> 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" } ; { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
HELP: switch 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" } ; { $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" ARTICLE: { "frp" "instances" } "FRP Instances"
"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. " "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." ; "Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;

View File

@ -14,11 +14,12 @@ 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-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
: <frp-table> ( model quot -- table ) : <frp-table> ( model -- table )
frp-table new-line-gadget dup >>renderer swap >>quot swap >>model frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
f <model> >>selected-value sans-serif-font >>font f <model> >>selected-value sans-serif-font >>font
focus-border-color >>focus-border-color focus-border-color >>focus-border-color
transparent >>column-line-color ; transparent >>column-line-color ;
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
: <frp-field> ( -- field ) f <model> <model-field> ; : <frp-field> ( -- field ) f <model> <model-field> ;
! Layout utilities ! Layout utilities
@ -27,11 +28,11 @@ GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ; M: gadget output-model model>> ;
M: frp-table output-model selected-value>> ; M: frp-table output-model selected-value>> ;
GENERIC: , ( object -- ) GENERIC: , ( uiitem -- )
M: gadget , make:, ; M: gadget , make:, ;
M: model , activate-model ; M: model , activate-model ;
GENERIC: -> ( object -- model ) GENERIC: -> ( uiitem -- model )
M: gadget -> dup make:, output-model ; M: gadget -> dup make:, output-model ;
M: model -> dup , ; M: model -> dup , ;
M: table -> dup , selected-value>> ; M: table -> dup , selected-value>> ;