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