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

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