unmaintained/4DNav/file-chooser/file-chooser.factor

   1 ! Copyright (C) 2008 Jeff Bigot
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING:
   4 kernel
   5 io.files
   6 io.backend
   7 io.directories
   8 io.files.info
   9 io.pathnames
  10 sequences
  11 models
  12 strings
  13 ui
  14 ui.operations
  15 ui.commands
  16 ui.gestures
  17 ui.gadgets
  18 ui.gadgets.buttons
  19 ui.gadgets.lists
  20 ui.gadgets.labels
  21 ui.gadgets.tracks
  22 ui.gadgets.packs
  23 ui.gadgets.panes
  24 ui.gadgets.scrollers
  25 prettyprint
  26 combinators
  27 accessors
  28 values
  29 tools.walker
  30 fry
  31 ;
  32 IN: 4DNav.file-chooser
  33
  34 TUPLE: file-chooser < track
  35     path
  36     extension
  37     selected-file
  38     presenter
  39     hook
  40     list
  41     ;
  42
  43 : find-file-list ( gadget -- list )
  44     [ file-chooser? ] find-parent list>> ;
  45
  46 file-chooser H{
  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 ] }
  57     { T{ button-down }
  58         request-focus }
  59     { T{ button-down f 1 }
  60         [ find-file-list invoke-value-action ]  }
  61 } set-gestures
  62
  63 : list-of-files ( file-chooser -- seq )
  64      [ path>> value>> directory-entries ] [ extension>> ] bi
  65      '[ [ name>> _ [ tail? ] with any? ]
  66      [ directory? ] bi or ]  filter
  67 ;
  68
  69 : update-filelist-model ( file-chooser -- )
  70     [ list-of-files ] [ model>> ] bi set-model ;
  71
  72 : init-filelist-model ( file-chooser -- file-chooser )
  73     dup list-of-files <model> >>model ;
  74
  75 : (fc-go) ( file-chooser button quot -- )
  76     [ [ file-chooser? ] find-parent dup path>> ] dip
  77     call
  78     normalize-path swap set-model
  79     update-filelist-model
  80     drop ; inline
  81
  82 : fc-go-parent ( file-chooser button -- )
  83     [ dup value>> parent-directory ] (fc-go) ;
  84
  85 : fc-go-home ( file-chooser button -- )
  86     [ home ] (fc-go) ;
  87
  88 : fc-change-directory ( file-chooser file -- )
  89     dupd [ path>> value>> normalize-path ] [ name>> ] bi*
  90     append-path over path>> set-model
  91     update-filelist-model
  92 ;
  93
  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
  97   call( path -- )
  98 ; inline
  99
 100 ! : fc-ok-action ( file-chooser -- quot )
 101 !  dup selected-file>> value>>  "" =
 102 !    [ drop [ drop ] ] [
 103 !            [ path>> value>> ]
 104 !            [ selected-file>> value>> append ]
 105 !            [ hook>> prefix ] tri
 106 !        [ drop ] prepend
 107 !    ]  if ;
 108
 109 : line-selected-action ( file-chooser -- )
 110      dup list>> list-value
 111      dup directory?
 112      [ fc-change-directory ] [ fc-load-file ] if ;
 113
 114 : present-dir-element ( element -- string )
 115     [ name>> ] [ directory? ] bi   [ "-> " prepend ] when ;
 116
 117 : <file-list> ( file-chooser -- list )
 118   dup [ nip line-selected-action ] curry
 119   [ present-dir-element ] rot model>> <list> ;
 120
 121 : <file-chooser> ( hook path extension -- gadget )
 122     { 0 1 } file-chooser new-track
 123     swap >>extension
 124     swap <model> >>path
 125     "" <model> >>selected-file
 126     swap >>hook
 127     init-filelist-model
 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
 132         <label> f track-add
 133     <shelf>
 134         "selected file : " <label> add-gadget
 135         over selected-file>> <label-control> add-gadget
 136     f track-add
 137     <shelf>
 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
 145     f track-add
 146     dup list>> <scroller> 1 track-add
 147 ;
 148
 149 M: file-chooser pref-dim* drop { 400 200 } ;
 150
 151 : file-chooser-window ( -- )
 152     [ . ] home { "xml" "txt" }   <file-chooser>
 153     "Choose a file" open-window ;
 154