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 accessors\r
  28 values\r
  29 tools.walker\r
  30 fry\r
  31 ;\r
  32 IN: 4DNav.file-chooser\r
  33 \r
  34 TUPLE: file-chooser < track \r
  35     path\r
  36     extension \r
  37     selected-file\r
  38     presenter\r
  39     hook  \r
  40     list\r
  41     ;\r
  42 \r
  43 : find-file-list ( gadget -- list )\r
  44     [ file-chooser? ] find-parent list>> ;\r
  45 \r
  46 file-chooser H{\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
  57     { T{ button-down } \r
  58         request-focus }\r
  59     { T{ button-down f 1 } \r
  60         [ find-file-list invoke-value-action ]  }\r
  61 } set-gestures\r
  62 \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
  67 ;\r
  68 \r
  69 : update-filelist-model ( file-chooser -- )\r
  70     [ list-of-files ] [ model>> ] bi set-model ;\r
  71 \r
  72 : init-filelist-model ( file-chooser -- file-chooser )\r
  73     dup list-of-files <model> >>model ; \r
  74 \r
  75 : (fc-go) ( file-chooser button quot -- )\r
  76     [ [ file-chooser? ] find-parent dup path>> ] dip\r
  77     call\r
  78     normalize-path swap set-model\r
  79     update-filelist-model\r
  80     drop ; inline\r
  81 \r
  82 : fc-go-parent ( file-chooser button -- )\r
  83     [ dup value>> parent-directory ] (fc-go) ;\r
  84 \r
  85 : fc-go-home ( file-chooser button -- )\r
  86     [ home ] (fc-go) ;\r
  87 \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
  92 ;\r
  93 \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
  97   call( path -- )\r
  98 ; inline\r
  99 \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
 106 !        [ drop ] prepend\r
 107 !    ]  if ; \r
 108 \r
 109 : line-selected-action ( file-chooser -- )\r
 110      dup list>> list-value\r
 111      dup directory? \r
 112      [ fc-change-directory ] [ fc-load-file ] if ;\r
 113 \r
 114 : present-dir-element ( element -- string )\r
 115     [ name>> ] [ directory? ] bi   [ "-> " prepend ] when ;\r
 116 \r
 117 : <file-list> ( file-chooser -- list )\r
 118   dup [ nip line-selected-action ] curry \r
 119   [ present-dir-element ] rot model>> <list> ;\r
 120 \r
 121 : <file-chooser> ( hook path extension -- gadget )\r
 122     { 0 1 } file-chooser new-track\r
 123     swap >>extension\r
 124     swap <model> >>path\r
 125     "" <model> >>selected-file\r
 126     swap >>hook\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
 133     <shelf> \r
 134         "selected file : " <label> add-gadget\r
 135         over selected-file>> <label-control> add-gadget\r
 136     f track-add\r
 137     <shelf> \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
 145     f track-add\r
 146     dup list>> <scroller> 1 track-add\r
 147 ;\r
 148 \r
 149 M: file-chooser pref-dim* drop { 400 200 } ;\r
 150 \r
 151 : file-chooser-window ( -- )\r
 152     [ . ] home { "xml" "txt" }   <file-chooser> \r
 153     "Choose a file" open-window ;\r
 154 \r