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" } \r
  49         [ find-file-list select-previous ] }\r
  50     { T{ key-down f f "DOWN" } \r
  51         [ find-file-list select-next ] }\r
  52     { T{ key-down f f "PAGE_UP" } \r
  53         [ find-file-list list-page-up ] }\r
  54     { T{ key-down f f "PAGE_DOWN" } \r
  55         [ find-file-list list-page-down ] }\r
  56     { T{ key-down f f "RET" } \r
  57         [ find-file-list invoke-value-action ] }\r
  58     { T{ button-down } \r
  59         request-focus }\r
  60     { T{ button-down f 1 } \r
  61         [ find-file-list invoke-value-action ]  }\r
  62 } set-gestures\r
  63 \r
  64 : list-of-files ( file-chooser -- seq )\r
  65      [ path>> value>> directory-entries ] [ extension>> ] bi\r
  66      '[ [ name>> _ [ tail? ] with any? ] \r
  67      [ directory? ] bi or ]  filter\r
  68 ;\r
  69 \r
  70 : update-filelist-model ( file-chooser -- file-chooser )\r
  71     [ list-of-files ] [ model>> ] bi set-model ;\r
  72 \r
  73 : init-filelist-model ( file-chooser -- file-chooser )\r
  74     dup list-of-files <model> >>model ; \r
  75 \r
  76 : (fc-go) ( file-chooser quot -- )\r
  77     [ [ file-chooser? ] find-parent dup path>> ] dip\r
  78     call\r
  79     normalize-path swap set-model\r
  80     update-filelist-model\r
  81     drop ;\r
  82 \r
  83 : fc-go-parent ( file-chooser -- )\r
  84     [ dup value>> parent-directory ] (fc-go) ;\r
  85 \r
  86 : fc-go-home ( file-chooser -- )\r
  87     [ home ] (fc-go) ;\r
  88 \r
  89 : fc-change-directory ( file-chooser file -- file-chooser )\r
  90     dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
  91     append-path over path>> set-model    \r
  92     update-filelist-model\r
  93 ;\r
  94 \r
  95 : fc-load-file ( file-chooser file -- )\r
  96   dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
  97   [ path>> value>> ] \r
  98   [ selected-file>> value>> append ] \r
  99   [ hook>> ] tri\r
 100   call\r
 101 ; inline\r
 102 \r
 103 ! : fc-ok-action ( file-chooser -- quot )\r
 104 !  dup selected-file>> value>>  "" =\r
 105 !    [ drop [ drop ] ] [    \r
 106 !            [ path>> value>> ] \r
 107 !            [ selected-file>> value>> append ] \r
 108 !            [ hook>> prefix ] tri\r
 109 !        [ drop ] prepend\r
 110 !    ]  if ; \r
 111 \r
 112 : line-selected-action ( file-chooser -- )\r
 113      dup list>> list-value\r
 114      dup directory? \r
 115      [ fc-change-directory ] [ fc-load-file ] if ;\r
 116 \r
 117 : present-dir-element ( element -- string )\r
 118     [ name>> ] [ directory? ] bi   [ "-> " prepend ] when ;\r
 119 \r
 120 : <file-list> ( file-chooser -- list )\r
 121   dup [ nip line-selected-action ] curry \r
 122   [ present-dir-element ] rot model>> <list> ;\r
 123 \r
 124 : <file-chooser> ( hook path extension -- gadget )\r
 125     { 0 1 } file-chooser new-track\r
 126     swap >>extension\r
 127     swap <model> >>path\r
 128     "" <model> >>selected-file\r
 129     swap >>hook\r
 130     init-filelist-model\r
 131     dup <file-list> >>list\r
 132     "choose a file in directory " <label> f track-add\r
 133     dup path>> <label-control> f track-add\r
 134     dup extension>> ", " join "limited to : " prepend \r
 135         <label> f track-add\r
 136     <shelf> \r
 137         "selected file : " <label> add-gadget\r
 138         over selected-file>> <label-control> add-gadget\r
 139     f track-add\r
 140     <shelf> \r
 141         over [  swap fc-go-parent ] curry  "go up" \r
 142             swap <bevel-button> add-gadget\r
 143         over [  swap fc-go-home ] curry  "go home" \r
 144             swap <bevel-button> add-gadget\r
 145     !    over [ swap fc-ok-action ] curry "OK" \r
 146     !    swap <bevel-button> add-gadget\r
 147     !    [ drop ]  "Cancel" swap <bevel-button> add-gadget\r
 148     f track-add\r
 149     dup list>> <scroller> 1 track-add\r
 150 ;\r
 151 \r
 152 M: file-chooser pref-dim* drop { 400 200 } ;\r
 153 \r
 154 : file-chooser-window ( -- )\r
 155     [ . ] home { "xml" "txt" }   <file-chooser> \r
 156     "Choose a file" open-window ;\r
 157 \r