-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING:\r
-kernel\r
-io.files\r
-io.backend\r
-io.directories\r
-io.files.info\r
-io.pathnames\r
-sequences\r
-models\r
-strings\r
-ui\r
-ui.operations\r
-ui.commands\r
-ui.gestures\r
-ui.gadgets\r
-ui.gadgets.buttons\r
-ui.gadgets.lists\r
-ui.gadgets.labels\r
-ui.gadgets.tracks\r
-ui.gadgets.packs\r
-ui.gadgets.panes\r
-ui.gadgets.scrollers\r
-prettyprint\r
-combinators\r
-accessors\r
-values\r
-tools.walker\r
-fry\r
-;\r
-IN: 4DNav.file-chooser\r
-\r
-TUPLE: file-chooser < track \r
- path\r
- extension \r
- selected-file\r
- presenter\r
- hook \r
- list\r
- ;\r
-\r
-: find-file-list ( gadget -- list )\r
- [ file-chooser? ] find-parent list>> ;\r
-\r
-file-chooser H{\r
- { T{ key-down f f "UP" } \r
- [ find-file-list select-previous ] }\r
- { T{ key-down f f "DOWN" } \r
- [ find-file-list select-next ] }\r
- { T{ key-down f f "PAGE_UP" } \r
- [ find-file-list list-page-up ] }\r
- { T{ key-down f f "PAGE_DOWN" } \r
- [ find-file-list list-page-down ] }\r
- { T{ key-down f f "RET" } \r
- [ find-file-list invoke-value-action ] }\r
- { T{ button-down } \r
- request-focus }\r
- { T{ button-down f 1 } \r
- [ find-file-list invoke-value-action ] }\r
-} set-gestures\r
-\r
-: list-of-files ( file-chooser -- seq )\r
- [ path>> value>> directory-entries ] [ extension>> ] bi\r
- '[ [ name>> _ [ tail? ] with any? ] \r
- [ directory? ] bi or ] filter\r
-;\r
-\r
-: update-filelist-model ( file-chooser -- )\r
- [ list-of-files ] [ model>> ] bi set-model ;\r
-\r
-: init-filelist-model ( file-chooser -- file-chooser )\r
- dup list-of-files <model> >>model ; \r
-\r
-: (fc-go) ( file-chooser button quot -- )\r
- [ [ file-chooser? ] find-parent dup path>> ] dip\r
- call\r
- normalize-path swap set-model\r
- update-filelist-model\r
- drop ; inline\r
-\r
-: fc-go-parent ( file-chooser button -- )\r
- [ dup value>> parent-directory ] (fc-go) ;\r
-\r
-: fc-go-home ( file-chooser button -- )\r
- [ home ] (fc-go) ;\r
-\r
-: fc-change-directory ( file-chooser file -- )\r
- dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
- append-path over path>> set-model \r
- update-filelist-model\r
-;\r
-\r
-: fc-load-file ( file-chooser file -- )\r
- over [ name>> ] [ selected-file>> ] bi* set-model \r
- [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
- call( path -- )\r
-; inline\r
-\r
-! : fc-ok-action ( file-chooser -- quot )\r
-! dup selected-file>> value>> "" =\r
-! [ drop [ drop ] ] [ \r
-! [ path>> value>> ] \r
-! [ selected-file>> value>> append ] \r
-! [ hook>> prefix ] tri\r
-! [ drop ] prepend\r
-! ] if ; \r
-\r
-: line-selected-action ( file-chooser -- )\r
- dup list>> list-value\r
- dup directory? \r
- [ fc-change-directory ] [ fc-load-file ] if ;\r
-\r
-: present-dir-element ( element -- string )\r
- [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
-\r
-: <file-list> ( file-chooser -- list )\r
- dup [ nip line-selected-action ] curry \r
- [ present-dir-element ] rot model>> <list> ;\r
-\r
-: <file-chooser> ( hook path extension -- gadget )\r
- { 0 1 } file-chooser new-track\r
- swap >>extension\r
- swap <model> >>path\r
- "" <model> >>selected-file\r
- swap >>hook\r
- init-filelist-model\r
- dup <file-list> >>list\r
- "choose a file in directory " <label> f track-add\r
- dup path>> <label-control> f track-add\r
- dup extension>> ", " join "limited to : " prepend \r
- <label> f track-add\r
- <shelf> \r
- "selected file : " <label> add-gadget\r
- over selected-file>> <label-control> add-gadget\r
- f track-add\r
- <shelf> \r
- over [ swap fc-go-parent ] curry "go up" \r
- swap <border-button> add-gadget\r
- over [ swap fc-go-home ] curry "go home" \r
- swap <border-button> add-gadget\r
- ! over [ swap fc-ok-action ] curry "OK" \r
- ! swap <bevel-button> add-gadget\r
- ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
- f track-add\r
- dup list>> <scroller> 1 track-add\r
-;\r
-\r
-M: file-chooser pref-dim* drop { 400 200 } ;\r
-\r
-: file-chooser-window ( -- )\r
- [ . ] home { "xml" "txt" } <file-chooser> \r
- "Choose a file" open-window ;\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+kernel
+io.files
+io.backend
+io.directories
+io.files.info
+io.pathnames
+sequences
+models
+strings
+ui
+ui.operations
+ui.commands
+ui.gestures
+ui.gadgets
+ui.gadgets.buttons
+ui.gadgets.lists
+ui.gadgets.labels
+ui.gadgets.tracks
+ui.gadgets.packs
+ui.gadgets.panes
+ui.gadgets.scrollers
+prettyprint
+combinators
+accessors
+values
+tools.walker
+fry
+;
+IN: 4DNav.file-chooser
+
+TUPLE: file-chooser < track
+ path
+ extension
+ selected-file
+ presenter
+ hook
+ list
+ ;
+
+: find-file-list ( gadget -- list )
+ [ file-chooser? ] find-parent list>> ;
+
+file-chooser H{
+ { T{ key-down f f "UP" }
+ [ find-file-list select-previous ] }
+ { T{ key-down f f "DOWN" }
+ [ find-file-list select-next ] }
+ { T{ key-down f f "PAGE_UP" }
+ [ find-file-list list-page-up ] }
+ { T{ key-down f f "PAGE_DOWN" }
+ [ find-file-list list-page-down ] }
+ { T{ key-down f f "RET" }
+ [ find-file-list invoke-value-action ] }
+ { T{ button-down }
+ request-focus }
+ { T{ button-down f 1 }
+ [ find-file-list invoke-value-action ] }
+} set-gestures
+
+: list-of-files ( file-chooser -- seq )
+ [ path>> value>> directory-entries ] [ extension>> ] bi
+ '[ [ name>> _ [ tail? ] with any? ]
+ [ directory? ] bi or ] filter
+;
+
+: update-filelist-model ( file-chooser -- )
+ [ list-of-files ] [ model>> ] bi set-model ;
+
+: init-filelist-model ( file-chooser -- file-chooser )
+ dup list-of-files <model> >>model ;
+
+: (fc-go) ( file-chooser button quot -- )
+ [ [ file-chooser? ] find-parent dup path>> ] dip
+ call
+ normalize-path swap set-model
+ update-filelist-model
+ drop ; inline
+
+: fc-go-parent ( file-chooser button -- )
+ [ dup value>> parent-directory ] (fc-go) ;
+
+: fc-go-home ( file-chooser button -- )
+ [ home ] (fc-go) ;
+
+: fc-change-directory ( file-chooser file -- )
+ dupd [ path>> value>> normalize-path ] [ name>> ] bi*
+ append-path over path>> set-model
+ update-filelist-model
+;
+
+: fc-load-file ( file-chooser file -- )
+ over [ name>> ] [ selected-file>> ] bi* set-model
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi
+ call( path -- )
+; inline
+
+! : fc-ok-action ( file-chooser -- quot )
+! dup selected-file>> value>> "" =
+! [ drop [ drop ] ] [
+! [ path>> value>> ]
+! [ selected-file>> value>> append ]
+! [ hook>> prefix ] tri
+! [ drop ] prepend
+! ] if ;
+
+: line-selected-action ( file-chooser -- )
+ dup list>> list-value
+ dup directory?
+ [ fc-change-directory ] [ fc-load-file ] if ;
+
+: present-dir-element ( element -- string )
+ [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;
+
+: <file-list> ( file-chooser -- list )
+ dup [ nip line-selected-action ] curry
+ [ present-dir-element ] rot model>> <list> ;
+
+: <file-chooser> ( hook path extension -- gadget )
+ { 0 1 } file-chooser new-track
+ swap >>extension
+ swap <model> >>path
+ "" <model> >>selected-file
+ swap >>hook
+ init-filelist-model
+ dup <file-list> >>list
+ "choose a file in directory " <label> f track-add
+ dup path>> <label-control> f track-add
+ dup extension>> ", " join "limited to : " prepend
+ <label> f track-add
+ <shelf>
+ "selected file : " <label> add-gadget
+ over selected-file>> <label-control> add-gadget
+ f track-add
+ <shelf>
+ over [ swap fc-go-parent ] curry "go up"
+ swap <border-button> add-gadget
+ over [ swap fc-go-home ] curry "go home"
+ swap <border-button> add-gadget
+ ! over [ swap fc-ok-action ] curry "OK"
+ ! swap <bevel-button> add-gadget
+ ! [ drop ] "Cancel" swap <bevel-button> add-gadget
+ f track-add
+ dup list>> <scroller> 1 track-add
+;
+
+M: file-chooser pref-dim* drop { 400 200 } ;
+
+: file-chooser-window ( -- )
+ [ . ] home { "xml" "txt" } <file-chooser>
+ "Choose a file" open-window ;
+
projects / factor.git / blobdiff