1 ! Copyright (C) 2008 Jeff Bigot
2 ! See http://factorcode.org/license.txt for BSD license.
32 IN: 4DNav.file-chooser
34 TUPLE: file-chooser < track
43 : find-file-list ( gadget -- list )
44 [ file-chooser? ] find-parent list>> ;
47 { T{ key-down f f "UP" }
48 [ find-file-list select-previous ] }
49 { T{ key-down f f "DOWN" }
50 [ find-file-list select-next ] }
51 { T{ key-down f f "PAGE_UP" }
52 [ find-file-list list-page-up ] }
53 { T{ key-down f f "PAGE_DOWN" }
54 [ find-file-list list-page-down ] }
55 { T{ key-down f f "RET" }
56 [ find-file-list invoke-value-action ] }
59 { T{ button-down f 1 }
60 [ find-file-list invoke-value-action ] }
63 : list-of-files ( file-chooser -- seq )
64 [ path>> value>> directory-entries ] [ extension>> ] bi
65 '[ [ name>> _ [ tail? ] with any? ]
66 [ directory? ] bi or ] filter
69 : update-filelist-model ( file-chooser -- )
70 [ list-of-files ] [ model>> ] bi set-model ;
72 : init-filelist-model ( file-chooser -- file-chooser )
73 dup list-of-files <model> >>model ;
75 : (fc-go) ( file-chooser button quot -- )
76 [ [ file-chooser? ] find-parent dup path>> ] dip
78 normalize-path swap set-model
82 : fc-go-parent ( file-chooser button -- )
83 [ dup value>> parent-directory ] (fc-go) ;
85 : fc-go-home ( file-chooser button -- )
88 : fc-change-directory ( file-chooser file -- )
89 dupd [ path>> value>> normalize-path ] [ name>> ] bi*
90 append-path over path>> set-model
94 : fc-load-file ( file-chooser file -- )
95 over [ name>> ] [ selected-file>> ] bi* set-model
96 [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi
100 ! : fc-ok-action ( file-chooser -- quot )
101 ! dup selected-file>> value>> "" =
102 ! [ drop [ drop ] ] [
104 ! [ selected-file>> value>> append ]
105 ! [ hook>> prefix ] tri
109 : line-selected-action ( file-chooser -- )
110 dup list>> list-value
112 [ fc-change-directory ] [ fc-load-file ] if ;
114 : present-dir-element ( element -- string )
115 [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;
117 : <file-list> ( file-chooser -- list )
118 dup [ nip line-selected-action ] curry
119 [ present-dir-element ] rot model>> <list> ;
121 : <file-chooser> ( hook path extension -- gadget )
122 { 0 1 } file-chooser new-track
125 "" <model> >>selected-file
128 dup <file-list> >>list
129 "choose a file in directory " <label> f track-add
130 dup path>> <label-control> f track-add
131 dup extension>> ", " join "limited to : " prepend
134 "selected file : " <label> add-gadget
135 over selected-file>> <label-control> add-gadget
138 over [ swap fc-go-parent ] curry "go up"
139 swap <border-button> add-gadget
140 over [ swap fc-go-home ] curry "go home"
141 swap <border-button> add-gadget
142 ! over [ swap fc-ok-action ] curry "OK"
143 ! swap <bevel-button> add-gadget
144 ! [ drop ] "Cancel" swap <bevel-button> add-gadget
146 dup list>> <scroller> 1 track-add
149 M: file-chooser pref-dim* drop { 400 200 } ;
151 : file-chooser-window ( -- )
152 [ . ] home { "xml" "txt" } <file-chooser>
153 "Choose a file" open-window ;