├── .gitignore ├── .travis.yml ├── HACKING.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── cabal.project.freeze ├── data └── Gtk │ ├── builder.xml │ └── icons │ ├── error.png │ ├── gtk-directory.png │ ├── gtk-file.png │ └── hsfm.png ├── hacking ├── HACKING.md └── hsimport.hs ├── hsfm.cabal ├── install.sh ├── src └── HSFM │ ├── FileSystem │ ├── FileType.hs │ └── UtilTypes.hs │ ├── GUI │ ├── Glib │ │ └── GlibString.hs │ ├── Gtk.hs │ └── Gtk │ │ ├── Callbacks.hs │ │ ├── Callbacks.hs-boot │ │ ├── Callbacks │ │ └── Utils.hs │ │ ├── Data.hs │ │ ├── Dialogs.hs │ │ ├── Errors.hs │ │ ├── Icons.hs │ │ ├── MyGUI.hs │ │ ├── MyView.hs │ │ ├── Plugins.hs │ │ ├── Settings.hs │ │ └── Utils.hs │ ├── History.hs │ ├── Settings.hs │ └── Utils │ ├── IO.hs │ └── MyPrelude.hs ├── update-gh-pages.sh └── update-index-state.sh /.gitignore: -------------------------------------------------------------------------------- 1 | *.hp 2 | *.old 3 | *.prof 4 | *~ 5 | .cabal-sandbox/ 6 | .ghc.environment.* 7 | .liquid/ 8 | .stack-work/ 9 | 3rdparty/hpath 10 | cabal.sandbox.config 11 | dist-newstyle/ 12 | dist/ 13 | hscope.out 14 | .ghcup 15 | /bin/ 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # See https://github.com/hvr/multi-ghc-travis for more information 2 | 3 | language: c 4 | 5 | sudo: required 6 | dist: trusty 7 | 8 | matrix: 9 | include: 10 | - env: CABALVER=1.24 GHCVER=8.0.1 11 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} 12 | - env: CABALVER=2.0 GHCVER=8.2.2 13 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} 14 | - env: CABALVER=2.2 GHCVER=8.4.1 15 | addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}} 16 | - env: CABALVER=head GHCVER=head 17 | addons: {apt: {packages: [cabal-install-head,ghc-head,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}} 18 | 19 | allow_failures: 20 | - env: CABALVER=head GHCVER=head 21 | 22 | env: 23 | global: 24 | - secure: "qAzj5tgAghFIfO6R/+Hdc5KcFhwXKNXMICNH7VLmqLzmYxk1UEkpi6hgX/f1bP5mLd07D+0IaeGFIUIWQOp+F/Du1NiX3yGbFuTt/Ja4I0K4ooCQc0w9uYLv8epxzp3VEOEI5sVCSpSomFjr7V0jwwTcBbxGUvv1VaGkJwAexRxCHuwU23KD0toECkVDsOMN/Gg2Ue/r2o+MsGx1/B9WMF0g6+zWlnrYfYZXWetl0DwATK5lZTa/21THdMrbuPX0fijGXTywvURDpCd3wIdfx9n7jPO2Gp2rcxPL/WkcIpzI211g4hEiheS+AlVyW39+C4i4MKaNK8YC+/5DRl/YHrFc7n3SZPDh+RMs6r3DS41RyRhQhz8DE0Pg4zfe/WUX4+h72TijCZ1zduh146rofwku/IGtCz5cuel+7cmTPk9ZyENYnH0ZMftkZjor9J/KamcMsN4zfaQBNJuIM3Kg8HVts3ymNIWrJ1LUn41MNt1eBDDvOWxZaHrjLyATRCFYvMr4RE01pqYKnWZ9RFfzVaYjD0QQWPWAXcCtkcAHSR6T0NxAqjLmHBNm+yWYIKG+bK2CvPNYTTNN8n4UvY1SrBpJEnLcRRns3U8nM7SVZ4GMaYzOTWtN1n0zamsl42wV0L/wqpz1SePkRZ34jca3V07XRLQSN2wjj8DyvOZUFR0=" 25 | 26 | before_install: 27 | - sudo apt-get install -y hscolour 28 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 29 | 30 | install: 31 | - cabal --version 32 | - travis_retry cabal update 33 | - cabal sandbox init 34 | - cabal install alex happy 35 | - export PATH="$(pwd)/.cabal-sandbox/bin:$PATH" 36 | - cabal install gtk2hs-buildtools 37 | - cabal install --only-dependencies --enable-tests -j 38 | 39 | script: 40 | - cabal configure --enable-tests -v2 41 | - cabal build 42 | - cabal test 43 | - cabal check 44 | - cabal sdist 45 | # check that the generated source-distribution can be built & installed 46 | - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; 47 | cd dist/; 48 | cabal sandbox init; 49 | if [ -f "$SRC_TGZ" ]; then 50 | cabal install alex happy; 51 | export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"; 52 | cabal install gtk2hs-buildtools; 53 | cabal install "$SRC_TGZ" --enable-tests; 54 | else 55 | echo "expected '$SRC_TGZ' not found"; 56 | exit 1; 57 | fi; 58 | cd .. 59 | - sed -i -e '/hsfm,/d' hsfm.cabal 60 | - cabal haddock --executables --internal --hyperlink-source --html-location=https://hackage.haskell.org/package/\$pkg-\$version/docs/ 61 | 62 | after_script: 63 | - ./update-gh-pages.sh 64 | 65 | notifications: 66 | email: 67 | - hasufell@posteo.de 68 | 69 | -------------------------------------------------------------------------------- /HACKING.md: -------------------------------------------------------------------------------- 1 | hacking/HACKING.md -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | HSFM 2 | ==== 3 | 4 | [![Join the chat at https://gitter.im/hasufell/hsfm](https://badges.gitter.im/hasufell/hsfm.svg)](https://gitter.im/hasufell/hsfm?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 5 | [![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](https://travis-ci.org/hasufell/hsfm) 6 | 7 | A Gtk+:3 filemanager written in Haskell. 8 | 9 | Design goals: 10 | 11 | - easy to use 12 | - useful library interface to be able to build other user interfaces 13 | - type safety, runtime safety, strictness 14 | - simple add-on interface 15 | 16 | Screenshots 17 | ----------- 18 | 19 | ![hsfm](https://cloud.githubusercontent.com/assets/1241845/20034565/6c3ae80e-a3c2-11e6-882c-9fe0ff202045.png "hsfm-gtk") 20 | 21 | Installation 22 | ------------ 23 | 24 | ``` 25 | ./install.sh 26 | ``` 27 | 28 | 29 | Contributing 30 | ------------ 31 | 32 | See [HACKING.md](hacking/HACKING.md). 33 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | with-compiler: ghc-8.6.5 2 | 3 | packages: . 4 | 5 | optimization: 2 6 | 7 | package * 8 | optimization: 2 9 | 10 | index-state: 2020-01-24T20:23:40Z 11 | -------------------------------------------------------------------------------- /cabal.project.freeze: -------------------------------------------------------------------------------- 1 | constraints: any.Cabal ==2.4.0.1, 2 | any.IfElse ==0.85, 3 | any.abstract-deque ==0.3, 4 | abstract-deque -usecas, 5 | any.alex ==3.2.5, 6 | alex +small_base, 7 | any.array ==0.5.3.0, 8 | any.atomic-primops ==0.8.3, 9 | atomic-primops -debug, 10 | any.base ==4.12.0.0, 11 | any.base-orphans ==0.8.1, 12 | any.binary ==0.8.6.0, 13 | any.bytestring ==0.10.8.2, 14 | any.cairo ==0.13.8.0, 15 | cairo +cairo_pdf +cairo_ps +cairo_svg, 16 | any.containers ==0.6.0.1, 17 | any.deepseq ==1.4.4.0, 18 | any.directory ==1.3.3.0, 19 | any.exceptions ==0.10.4, 20 | exceptions +transformers-0-4, 21 | any.filepath ==1.4.2.1, 22 | any.ghc-boot-th ==8.6.5, 23 | any.ghc-prim ==0.5.3, 24 | any.gio ==0.13.8.0, 25 | any.glib ==0.13.8.0, 26 | glib +closure_signals, 27 | any.gtk2hs-buildtools ==0.13.8.0, 28 | gtk2hs-buildtools +closuresignals, 29 | any.gtk3 ==0.15.4, 30 | gtk3 -build-demos +fmode-binary +have-gio, 31 | any.happy ==1.19.12, 32 | happy +small_base, 33 | any.hashable ==1.3.0.0, 34 | hashable -examples +integer-gmp +sse2 -sse41, 35 | any.hashtables ==1.2.3.4, 36 | hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks, 37 | any.heaps ==0.3.6.1, 38 | any.hinotify-bytestring ==0.3.8.1, 39 | any.hpath ==0.11.0, 40 | any.hpath-filepath ==0.10.3, 41 | any.hpath-io ==0.12.0, 42 | any.hsc2hs ==0.68.6, 43 | hsc2hs -in-ghc-tree, 44 | any.integer-gmp ==1.0.2.0, 45 | any.lockfree-queue ==0.2.3.1, 46 | any.monad-control ==1.0.2.3, 47 | any.monad-loops ==0.4.3, 48 | monad-loops +base4, 49 | any.mtl ==2.2.2, 50 | any.network ==3.1.1.1, 51 | any.old-locale ==1.0.0.7, 52 | any.pango ==0.13.8.0, 53 | pango +new-exception, 54 | any.parsec ==3.1.13.0, 55 | any.pretty ==1.1.3.6, 56 | any.primitive ==0.7.0.0, 57 | any.process ==1.6.5.0, 58 | any.random ==1.1, 59 | any.rts ==1.0, 60 | any.safe ==0.3.18, 61 | any.safe-exceptions ==0.1.7.0, 62 | any.simple-sendfile ==0.2.30, 63 | simple-sendfile +allow-bsd, 64 | any.stm ==2.5.0.0, 65 | any.streamly ==0.7.0, 66 | streamly -benchmark -debug -dev -examples -examples-sdl -has-llvm -inspection -no-charts -no-fusion -streamk, 67 | any.template-haskell ==2.14.0.0, 68 | any.text ==1.2.3.1, 69 | any.time ==1.8.0.2, 70 | any.transformers ==0.5.6.2, 71 | any.transformers-base ==0.4.5.2, 72 | transformers-base +orphaninstances, 73 | any.transformers-compat ==0.6.5, 74 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 75 | any.unix ==2.7.2.2, 76 | any.unix-bytestring ==0.3.7.3, 77 | any.utf8-string ==1.0.1.1, 78 | any.vector ==0.12.0.3, 79 | vector +boundschecks -internalchecks -unsafechecks -wall, 80 | any.word8 ==0.1.3 81 | -------------------------------------------------------------------------------- /data/Gtk/builder.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | True 7 | False 8 | 2 9 | 2 10 | True 11 | 12 | 13 | True 14 | False 15 | start 16 | 5 17 | File Name: 18 | 19 | 20 | 21 | 22 | 23 | 0 24 | 0 25 | 26 | 27 | 28 | 29 | 350 30 | True 31 | True 32 | 5 33 | 5 34 | 2 35 | 2 36 | False 37 | 38 | 39 | 1 40 | 0 41 | 42 | 43 | 44 | 45 | True 46 | False 47 | start 48 | 5 49 | Location: 50 | 51 | 52 | 53 | 54 | 55 | 0 56 | 1 57 | 58 | 59 | 60 | 61 | True 62 | False 63 | start 64 | 5 65 | Total Size: 66 | 67 | 68 | 69 | 70 | 71 | 0 72 | 2 73 | 74 | 75 | 76 | 77 | 350 78 | True 79 | True 80 | 5 81 | 5 82 | 2 83 | 2 84 | False 85 | 86 | 87 | 1 88 | 1 89 | 90 | 91 | 92 | 93 | 350 94 | True 95 | True 96 | 5 97 | 5 98 | 2 99 | 2 100 | False 101 | 102 | 103 | 1 104 | 2 105 | 106 | 107 | 108 | 109 | True 110 | False 111 | start 112 | 5 113 | Accessed: 114 | 115 | 116 | 117 | 118 | 119 | 0 120 | 7 121 | 122 | 123 | 124 | 125 | True 126 | False 127 | start 128 | 5 129 | Modified: 130 | 131 | 132 | 133 | 134 | 135 | 0 136 | 6 137 | 138 | 139 | 140 | 141 | 350 142 | True 143 | True 144 | 5 145 | 5 146 | 2 147 | 2 148 | False 149 | 150 | 151 | 1 152 | 6 153 | 154 | 155 | 156 | 157 | 350 158 | True 159 | True 160 | 5 161 | 5 162 | 2 163 | 2 164 | False 165 | 166 | 167 | 1 168 | 7 169 | 170 | 171 | 172 | 173 | True 174 | False 175 | start 176 | 5 177 | File Type: 178 | 179 | 180 | 181 | 182 | 183 | 0 184 | 3 185 | 186 | 187 | 188 | 189 | True 190 | True 191 | 5 192 | 5 193 | 2 194 | 2 195 | False 196 | 197 | 198 | 1 199 | 3 200 | 201 | 202 | 203 | 204 | True 205 | True 206 | 5 207 | 5 208 | 2 209 | 2 210 | False 211 | 212 | 213 | 1 214 | 4 215 | 216 | 217 | 218 | 219 | True 220 | False 221 | start 222 | 5 223 | Link Destination: 224 | 225 | 226 | 227 | 228 | 229 | 0 230 | 5 231 | 232 | 233 | 234 | 235 | True 236 | False 237 | start 238 | 5 239 | Permissions: 240 | 241 | 242 | 243 | 244 | 245 | 0 246 | 4 247 | 248 | 249 | 250 | 251 | True 252 | True 253 | 5 254 | 5 255 | 2 256 | 2 257 | False 258 | 259 | 260 | 1 261 | 5 262 | 263 | 264 | 265 | 266 | True 267 | False 268 | gtk-edit 269 | 270 | 271 | True 272 | False 273 | gtk-open 274 | 275 | 276 | True 277 | False 278 | gtk-cancel 279 | 280 | 281 | False 282 | 283 | 284 | True 285 | False 286 | vertical 287 | 288 | 289 | True 290 | False 291 | 292 | 293 | True 294 | False 295 | _File 296 | True 297 | 298 | 299 | True 300 | False 301 | 302 | 303 | True 304 | False 305 | 306 | 307 | 308 | 309 | gtk-quit 310 | True 311 | False 312 | True 313 | True 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | 322 | True 323 | False 324 | View 325 | 326 | 327 | True 328 | False 329 | 330 | 331 | 332 | 333 | 334 | 335 | True 336 | False 337 | _Help 338 | True 339 | 340 | 341 | True 342 | False 343 | 344 | 345 | gtk-about 346 | True 347 | False 348 | True 349 | True 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | False 359 | True 360 | 0 361 | 362 | 363 | 364 | 365 | True 366 | False 367 | 368 | 369 | True 370 | True 371 | 372 | 373 | True 374 | True 375 | True 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | True 397 | True 398 | 399 | 400 | 401 | 402 | True 403 | True 404 | True 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | 424 | 425 | True 426 | True 427 | 428 | 429 | 430 | 431 | True 432 | True 433 | 2 434 | 435 | 436 | 437 | 438 | True 439 | True 440 | 1 441 | 442 | 443 | 444 | 445 | True 446 | False 447 | 448 | 449 | True 450 | True 451 | True 452 | 5 453 | 5 454 | 5 455 | 5 456 | none 457 | True 458 | 459 | 460 | 461 | 462 | 463 | False 464 | True 465 | 0 466 | 467 | 468 | 469 | 470 | True 471 | False 472 | 2 473 | 2 474 | 475 | 476 | False 477 | True 478 | 1 479 | 480 | 481 | 482 | 483 | True 484 | False 485 | 10 486 | 10 487 | 10 488 | 10 489 | 6 490 | 6 491 | vertical 492 | 2 493 | 494 | 495 | True 496 | True 497 | 2 498 | 499 | 500 | 501 | 502 | True 503 | True 504 | True 505 | 5 506 | 5 507 | 5 508 | 5 509 | image3 510 | 511 | 512 | False 513 | True 514 | 3 515 | 516 | 517 | 518 | 519 | True 520 | False 521 | 2 522 | 2 523 | 524 | 525 | False 526 | True 527 | 4 528 | 529 | 530 | 531 | 532 | True 533 | True 534 | True 535 | 5 536 | 5 537 | 5 538 | 5 539 | none 540 | True 541 | 542 | 543 | 544 | 545 | 546 | False 547 | True 548 | 5 549 | 550 | 551 | 552 | 553 | False 554 | True 555 | 2 556 | 557 | 558 | 559 | 560 | 561 | 562 | True 563 | False 564 | gtk-zoom-in 565 | 566 | 567 | True 568 | False 569 | gtk-zoom-out 570 | 571 | 572 | True 573 | False 574 | gtk-directory 575 | 576 | 577 | True 578 | False 579 | gtk-zoom-fit 580 | 581 | 582 | True 583 | False 584 | gtk-add 585 | 586 | 587 | True 588 | False 589 | utilities-terminal 590 | 591 | 592 | True 593 | False 594 | 595 | 596 | gtk-open 597 | True 598 | False 599 | True 600 | True 601 | 602 | 603 | 604 | 605 | gtk-execute 606 | True 607 | False 608 | True 609 | True 610 | 611 | 612 | 613 | 614 | gtk-new 615 | True 616 | False 617 | True 618 | True 619 | 620 | 621 | True 622 | False 623 | 624 | 625 | gtk-file 626 | True 627 | False 628 | True 629 | True 630 | 631 | 632 | 633 | 634 | directory 635 | True 636 | False 637 | image6 638 | False 639 | 640 | 641 | 642 | 643 | True 644 | False 645 | 646 | 647 | 648 | 649 | Tab 650 | True 651 | False 652 | image8 653 | False 654 | 655 | 656 | 657 | 658 | Terminal 659 | True 660 | False 661 | image9 662 | False 663 | 664 | 665 | 666 | 667 | 668 | 669 | 670 | 671 | True 672 | False 673 | 674 | 675 | 676 | 677 | gtk-cut 678 | True 679 | False 680 | True 681 | True 682 | 683 | 684 | 685 | 686 | gtk-copy 687 | True 688 | False 689 | True 690 | True 691 | 692 | 693 | 694 | 695 | Rename 696 | True 697 | False 698 | False 699 | 700 | 701 | 702 | 703 | gtk-paste 704 | True 705 | False 706 | True 707 | True 708 | 709 | 710 | 711 | 712 | gtk-delete 713 | True 714 | False 715 | True 716 | True 717 | 718 | 719 | 720 | 721 | gtk-properties 722 | True 723 | False 724 | True 725 | True 726 | 727 | 728 | 729 | 730 | True 731 | False 732 | 733 | 734 | 735 | 736 | View 737 | True 738 | False 739 | image7 740 | False 741 | 742 | 743 | True 744 | False 745 | 746 | 747 | icon view 748 | True 749 | False 750 | image4 751 | False 752 | 753 | 754 | 755 | 756 | tree view 757 | True 758 | False 759 | image5 760 | False 761 | 762 | 763 | 764 | 765 | 766 | 767 | 768 | 769 | True 770 | False 771 | gtk-yes 772 | 773 | 774 | True 775 | False 776 | gtk-yes 777 | 778 | 779 | True 780 | False 781 | vertical 782 | 783 | 784 | True 785 | False 786 | 787 | 788 | True 789 | True 790 | True 791 | 792 | 793 | True 794 | False 795 | gtk-go-back 796 | 797 | 798 | 799 | 800 | False 801 | True 802 | 2 803 | 0 804 | 805 | 806 | 807 | 808 | True 809 | True 810 | True 811 | 812 | 813 | True 814 | False 815 | gtk-go-up 816 | 817 | 818 | 819 | 820 | False 821 | True 822 | 2 823 | 1 824 | 825 | 826 | 827 | 828 | True 829 | True 830 | True 831 | 832 | 833 | True 834 | False 835 | gtk-go-forward 836 | 837 | 838 | 839 | 840 | False 841 | True 842 | 2 843 | 2 844 | 845 | 846 | 847 | 848 | True 849 | True 850 | True 851 | 852 | 853 | True 854 | False 855 | gtk-refresh 856 | 857 | 858 | 859 | 860 | False 861 | True 862 | 2 863 | 3 864 | 865 | 866 | 867 | 868 | True 869 | True 870 | True 871 | 872 | 873 | True 874 | False 875 | gtk-home 876 | 877 | 878 | 879 | 880 | False 881 | True 882 | 4 883 | 884 | 885 | 886 | 887 | True 888 | True 889 | url 890 | 891 | 892 | True 893 | True 894 | 5 895 | 896 | 897 | 898 | 899 | False 900 | True 901 | 0 902 | 903 | 904 | 905 | 906 | 300 907 | 500 908 | True 909 | True 910 | in 911 | 912 | 913 | 914 | 915 | 916 | True 917 | True 918 | 2 919 | 920 | 921 | 922 | 923 | -------------------------------------------------------------------------------- /data/Gtk/icons/error.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hasufell/hsfm/322c766ae534fb21e3427d2845011123ddb90952/data/Gtk/icons/error.png -------------------------------------------------------------------------------- /data/Gtk/icons/gtk-directory.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hasufell/hsfm/322c766ae534fb21e3427d2845011123ddb90952/data/Gtk/icons/gtk-directory.png -------------------------------------------------------------------------------- /data/Gtk/icons/gtk-file.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hasufell/hsfm/322c766ae534fb21e3427d2845011123ddb90952/data/Gtk/icons/gtk-file.png -------------------------------------------------------------------------------- /data/Gtk/icons/hsfm.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hasufell/hsfm/322c766ae534fb21e3427d2845011123ddb90952/data/Gtk/icons/hsfm.png -------------------------------------------------------------------------------- /hacking/HACKING.md: -------------------------------------------------------------------------------- 1 | # HACKING 2 | 3 | Check out the [issue tracker](https://github.com/hasufell/hsfm/issues) 4 | if you don't know yet what you want to hack on. 5 | 6 | ## Coding style 7 | 8 | - match the sorroundings 9 | - no overcomplicated pointfree style 10 | - normal indenting 2 whitespaces 11 | - just make things pretty and readable 12 | - you can use the provided [hsimport.hs](hsimport.hs) 13 | 14 | ## Documentation 15 | 16 | __Everything__ must be documented. :) 17 | Don't assume people know what you mean. Type signatures are not sufficient 18 | documentation. 19 | 20 | ## Hacking Overview 21 | 22 | Only a GTK GUI is currently implemented, the entry point being 23 | [HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down 24 | to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in 25 | [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs), which is sort of 26 | a global object for the whole window. Inside this object are 27 | theoretically multiple [MyView objects](./../src/HSFM/GUI/Gtk/Data.hs#L101) 28 | allowed which represent the actual view on the filesystem and related 29 | widgets, which are constructed in 30 | [HSFM.GUI.Gtk.MyView](./../src/HSFM/GUI/Gtk/MyView.hs). Both MyGUI and MyView 31 | are more or less accessible throughout the whole GTK callstack, expclicitly 32 | passed as parameters. 33 | 34 | For adding new GTK widgets with functionality you mostly have to touch the 35 | following files: 36 | * [builder.xml](./../data/Gtk/builder.xml): this defines the main GUI widgets which are static, use the [glade editor](http://glade.gnome.org) to add stuff 37 | * [HSFM.GUI.Gtk.Data](./../src/HSFM/GUI/Gtk/Data.hs): add the widget to e.g. the MyGUI type so we can access it throughout the GTK call stack 38 | * [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file 39 | * [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here 40 | 41 | ## Concepts 42 | 43 | ### Path safety 44 | 45 | Paths are usually represented in haskell libraries as `type FilePath = String`. 46 | This is bad, because of a number of reasons: 47 | * encoding issues, since the low-level representation of filepaths is in fact an array of C chars 48 | * weak typing... we could pass arbitrary invalid/malicious filepaths or other random strings 49 | * no information about any property at type level (e.g. is it an absolute path?) 50 | * no filepath constructors that do sanity checks and proper parsing 51 | * no guarantee whether the filepath is normalised or not or even valid 52 | 53 | Because of that, the solution is: 54 | * use `ByteString` under the hood 55 | * wrap it inside `Path t` where `t` can be either `Abs` (for absolute), `Rel` (for relative) or `Fn` (for filename) 56 | * construct filepaths via smart constructors only that reject certain paths (like `.` or `..`) and normalise the path 57 | 58 | This leads to the following benefits: 59 | * we have guarantees about whether a path is absolute or not, which is important for runtime safety in general, predictable behavior and thread safety 60 | * we don't mess with the filepath representation we get from low-level posix functions, so encoding issues are pretty much out 61 | * we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist") 62 | * filepath functions like `()` are now predictable and safe in contrast to the version from the `filepath` package 63 | 64 | The [hpath](https://hackage.haskell.org/package/hpath) library does exactly that for us. 65 | 66 | The only problem with this approach is that most libraries are still String 67 | based. Some provide dedicated `Foo.ByteString` modules though, but it 68 | might be necessary to fork libraries. 69 | We also need to keep track of the [Abstract FilePath proposal](https://ghc.haskell.org/trac/ghc/wiki/Proposal/AbstractFilePath). 70 | 71 | Almost all paths in HSFM are only allowed to be absolute (`Path Abs`), unless 72 | they are filenames (`Path Fn`) and processed for GUI purposes. This is as 73 | already mentioned for the purpose of runtime safety, predictability and 74 | thread safety. 75 | 76 | ### File IO safety 77 | 78 | This is a pretty difficult problem. One thing to ensure safety on IO level 79 | is simply the strong haskell type system, since we push everything 80 | into our `File a` type and can then pattern match easily against the different 81 | types of files. 82 | 83 | The only problem with this approach is that we are examining a file at point 84 | `a` in time, safe the information and then use that information further down 85 | the call stack at point `b` in time, when the file information in memory 86 | could already be out of date. There are two approaches to make this less 87 | sucky: 88 | * use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes 89 | * when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized then the file at the given path is read and the copy/move/whatnot function carried out immediately 90 | 91 | In addition, we don't use the `directory` package, which is dangerous 92 | and broken. Instead, we use the [HPath.IO](https://hackage.haskell.org/package/hpath/docs/HPath-IO.html). 93 | 94 | ### Exception handling 95 | 96 | Exceptions are good. We don't want to wrap everything in Maybe/Either types 97 | unless we want to handle failure immediately. Otherwise we need to make 98 | sure that at least at some point IOExceptions are caught and visualized 99 | to the user. This is often done via e.g. `withErrorDialog` which catches 100 | `IOException` and [HPathIOException](https://hackage.haskell.org/package/hpath/docs/HPath-IO-Errors.html#t:HPathIOException). 101 | 102 | It's also important to clean up stuff like filedescriptors via 103 | functions like `bracket` directly in our low-level code in case 104 | something goes wrong. 105 | 106 | -------------------------------------------------------------------------------- /hacking/hsimport.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import qualified Language.Haskell.Exts as HS 3 | import HsImport 4 | 5 | main :: IO () 6 | main = hsimport $ defaultConfig { prettyPrint = prettyPrint 7 | , findImportPos = findImportPos } 8 | where 9 | prettyPrint :: HS.ImportDecl -> String 10 | prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) = 11 | "import " ++ (ifStr qual "qualified ") ++ 12 | (maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++ 13 | getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++ 14 | specprint mspec 15 | 16 | specprint :: Maybe (Bool, [HS.ImportSpec]) -> String 17 | specprint Nothing = "" 18 | specprint (Just (False, xs)) 19 | = "\n (\n" ++ printImportSpecs xs ++ " )" 20 | specprint (Just (True, xs)) 21 | = "\n hiding (\n" ++ printImportSpecs xs ++ " )" 22 | 23 | printImportSpecs :: [HS.ImportSpec] -> String 24 | printImportSpecs ins 25 | = let (x:xs) = sort ins 26 | in " " ++ printSpec x ++ "\n" ++ go xs 27 | where 28 | go [] = "" 29 | go [x'] = " , " ++ printSpec x' ++ "\n" 30 | go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs' 31 | printSpec :: HS.ImportSpec -> String 32 | printSpec = HS.prettyPrint 33 | 34 | 35 | findImportPos :: HS.ImportDecl -> [HS.ImportDecl] -> Maybe ImportPos 36 | findImportPos _ [] = Nothing 37 | findImportPos newImport currentImports = Just findPos 38 | where 39 | lastPos = After . last $ currentImports 40 | findPos = let xs = takeWhile (\x -> (getMN $ HS.importModule x) 41 | < 42 | (getMN $ HS.importModule newImport) 43 | ) 44 | . sort 45 | $ currentImports 46 | in if null xs then lastPos else After . last $ xs 47 | 48 | ifStr :: Bool -> String -> String 49 | ifStr True str = str 50 | ifStr False _ = "" 51 | 52 | getMN :: HS.ModuleName -> String 53 | getMN (HS.ModuleName name) = name 54 | -------------------------------------------------------------------------------- /hsfm.cabal: -------------------------------------------------------------------------------- 1 | name: hsfm 2 | version: 0.0.0.1 3 | synopsis: Haskell FileManager 4 | description: FileManager written in haskell 5 | license: GPL-2 6 | license-file: LICENSE 7 | author: Julian Ospald 8 | maintainer: hasufell@hasufell.de 9 | copyright: Copyright: (c) 2016 Julian Ospald 10 | homepage: https://github.com/hasufell/hsfm 11 | category: Desktop 12 | build-type: Simple 13 | cabal-version: >=1.22 14 | 15 | data-files: 16 | LICENSE 17 | data/Gtk/builder.xml 18 | data/Gtk/icons/error.png 19 | data/Gtk/icons/gtk-directory.png 20 | data/Gtk/icons/gtk-file.png 21 | data/Gtk/icons/hsfm.png 22 | hsfm.cabal 23 | 24 | 25 | library 26 | exposed-modules: 27 | HSFM.FileSystem.FileType 28 | HSFM.FileSystem.UtilTypes 29 | HSFM.History 30 | HSFM.Settings 31 | HSFM.Utils.IO 32 | HSFM.Utils.MyPrelude 33 | 34 | build-depends: 35 | IfElse, 36 | base >= 4.8 && < 5, 37 | bytestring, 38 | filepath >= 1.3.0.0, 39 | hinotify-bytestring, 40 | hpath >= 0.11.0 , 41 | hpath-filepath >= 0.10.3, 42 | hpath-io >= 0.12.0, 43 | safe, 44 | stm, 45 | time >= 1.4.2, 46 | unix, 47 | utf8-string 48 | hs-source-dirs: src 49 | default-language: Haskell2010 50 | Default-Extensions: RecordWildCards 51 | PatternSynonyms 52 | FlexibleInstances 53 | ViewPatterns 54 | ghc-options: 55 | -Wall 56 | 57 | executable hsfm-gtk 58 | main-is: HSFM/GUI/Gtk.hs 59 | other-modules: 60 | Paths_hsfm 61 | HSFM.FileSystem.FileType 62 | HSFM.FileSystem.UtilTypes 63 | HSFM.GUI.Glib.GlibString 64 | HSFM.GUI.Gtk.Callbacks 65 | HSFM.GUI.Gtk.Callbacks.Utils 66 | HSFM.GUI.Gtk.Data 67 | HSFM.GUI.Gtk.Dialogs 68 | HSFM.GUI.Gtk.Errors 69 | HSFM.GUI.Gtk.Icons 70 | HSFM.GUI.Gtk.MyGUI 71 | HSFM.GUI.Gtk.MyView 72 | HSFM.GUI.Gtk.Plugins 73 | HSFM.GUI.Gtk.Settings 74 | HSFM.GUI.Gtk.Utils 75 | HSFM.History 76 | HSFM.Settings 77 | HSFM.Utils.IO 78 | HSFM.Utils.MyPrelude 79 | 80 | build-depends: 81 | Cabal >= 1.22.0.0, 82 | IfElse, 83 | base >= 4.8 && < 5, 84 | bytestring, 85 | filepath >= 1.3.0.0, 86 | glib >= 0.13, 87 | gtk3 >= 0.14.1, 88 | hinotify-bytestring, 89 | hpath >= 0.11.0 , 90 | hpath-filepath >= 0.10.3, 91 | hpath-io >= 0.12.0, 92 | hsfm, 93 | monad-loops, 94 | old-locale >= 1, 95 | process, 96 | safe, 97 | simple-sendfile, 98 | stm, 99 | time >= 1.4.2, 100 | transformers, 101 | unix, 102 | unix-bytestring, 103 | utf8-string, 104 | word8 105 | hs-source-dirs: src 106 | default-language: Haskell2010 107 | Default-Extensions: RecordWildCards 108 | PatternSynonyms 109 | FlexibleInstances 110 | ViewPatterns 111 | ghc-options: 112 | -Wall 113 | 114 | source-repository head 115 | type: git 116 | location: https://github.com/hasufell/hsfm 117 | 118 | -------------------------------------------------------------------------------- /install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -eu 4 | 5 | SCRIPT_DIR="$(CDPATH="" cd -- "$(dirname -- "$0")" && pwd -P)" 6 | 7 | cd "${SCRIPT_DIR}" 8 | 9 | # install ghcup 10 | if ! [ -e "${SCRIPT_DIR}"/.ghcup/bin/ghcup ] ; then 11 | mkdir -p "${SCRIPT_DIR}"/.ghcup/bin 12 | curl --proto '=https' --tlsv1.2 -sSf https://gitlab.haskell.org/haskell/ghcup/raw/master/ghcup > "${SCRIPT_DIR}"/.ghcup/bin/ghcup 13 | chmod +x "${SCRIPT_DIR}"/.ghcup/bin/ghcup 14 | fi 15 | 16 | # set up environment 17 | export PATH="${SCRIPT_DIR}/.ghcup/bin:$PATH" 18 | export GHCUP_INSTALL_BASE_PREFIX="${SCRIPT_DIR}" 19 | 20 | # get ghc version from cabal.project 21 | ghc_ver=$(grep with-compiler cabal.project | awk '{print $2}' | sed 's/ghc-//') 22 | 23 | # install ghc 24 | if ! ghcup list -t ghc -c installed -r | grep -q "${ghc_ver}" ; then 25 | ghcup install "${ghc_ver}" 26 | fi 27 | 28 | # install cabal-install 29 | if [ -z "$(ghcup list -t cabal-install -c installed -r)" ] ; then 30 | ghcup install-cabal 31 | fi 32 | 33 | [ -e "${SCRIPT_DIR}"/bin ] || mkdir "${SCRIPT_DIR}"/bin 34 | 35 | # install binary 36 | cabal v2-install \ 37 | --installdir="${SCRIPT_DIR}"/bin \ 38 | --install-method=copy \ 39 | --overwrite-policy=always 40 | 41 | echo "Binary installed in: ${SCRIPT_DIR}/bin" 42 | 43 | -------------------------------------------------------------------------------- /src/HSFM/FileSystem/FileType.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | 22 | -- |This module provides a data type for representing directories/files 23 | -- in a well-typed and convenient way. This is useful to gather and 24 | -- save information about a file, so the information can be easily 25 | -- processed in e.g. a GUI. 26 | -- 27 | -- However, it's not meant to be used to interact with low-level 28 | -- functions that copy files etc, since there's no guarantee that 29 | -- the in-memory representation of the type still matches what is 30 | -- happening on filesystem level. 31 | -- 32 | -- If you interact with low-level libraries, you must not pattern 33 | -- match on the `File a` type. Instead, you should only use the saved 34 | -- `path` and make no assumptions about the file the path might or 35 | -- might not point to. 36 | module HSFM.FileSystem.FileType where 37 | 38 | 39 | 40 | import Data.ByteString(ByteString) 41 | import Data.ByteString.UTF8 42 | ( 43 | toString 44 | ) 45 | import Data.Time.Clock.POSIX 46 | ( 47 | POSIXTime 48 | , posixSecondsToUTCTime 49 | ) 50 | import Data.Time() 51 | import HPath 52 | ( 53 | Abs 54 | , Path 55 | ) 56 | import qualified HPath as P 57 | import HPath.IO hiding (FileType(..)) 58 | import HPath.IO.Errors 59 | import Prelude hiding(readFile) 60 | import System.Posix.FilePath 61 | ( 62 | () 63 | ) 64 | import System.Posix.Directory.Traversals 65 | ( 66 | realpath 67 | ) 68 | import qualified System.Posix.Files.ByteString as PF 69 | import System.Posix.Types 70 | ( 71 | DeviceID 72 | , EpochTime 73 | , FileID 74 | , FileMode 75 | , FileOffset 76 | , GroupID 77 | , LinkCount 78 | , UserID 79 | ) 80 | 81 | 82 | 83 | 84 | 85 | 86 | ---------------------------- 87 | --[ BASE TYPES ]-- 88 | ---------------------------- 89 | 90 | 91 | -- |The String in the path field is always a full path. 92 | -- The free type variable is used in the File/Dir constructor and can hold 93 | -- Handles, Strings representing a file's contents or anything else you can 94 | -- think of. 95 | data File a = 96 | Dir { 97 | path :: !(Path Abs) 98 | , fvar :: a 99 | } 100 | | RegFile { 101 | path :: !(Path Abs) 102 | , fvar :: a 103 | } 104 | | SymLink { 105 | path :: !(Path Abs) 106 | , fvar :: a 107 | , sdest :: Maybe (File a) -- ^ symlink madness, 108 | -- we need to know where it points to 109 | , rawdest :: !ByteString 110 | } 111 | | BlockDev { 112 | path :: !(Path Abs) 113 | , fvar :: a 114 | } 115 | | CharDev { 116 | path :: !(Path Abs) 117 | , fvar :: a 118 | } 119 | | NamedPipe { 120 | path :: !(Path Abs) 121 | , fvar :: a 122 | } 123 | | Socket { 124 | path :: !(Path Abs) 125 | , fvar :: a 126 | } deriving (Show, Eq) 127 | 128 | 129 | -- |Low-level file information. 130 | data FileInfo = FileInfo { 131 | deviceID :: !DeviceID 132 | , fileID :: !FileID 133 | , fileMode :: !FileMode 134 | , linkCount :: !LinkCount 135 | , fileOwner :: !UserID 136 | , fileGroup :: !GroupID 137 | , specialDeviceID :: !DeviceID 138 | , fileSize :: !FileOffset 139 | , accessTime :: !EpochTime 140 | , modificationTime :: !EpochTime 141 | , statusChangeTime :: !EpochTime 142 | , accessTimeHiRes :: !POSIXTime 143 | , modificationTimeHiRes :: !POSIXTime 144 | , statusChangeTimeHiRes :: !POSIXTime 145 | } deriving (Show, Eq, Ord) 146 | 147 | 148 | 149 | 150 | ------------------------------------ 151 | --[ ViewPatterns/PatternSynonyms ]-- 152 | ------------------------------------ 153 | 154 | 155 | 156 | 157 | ---- Filetypes ---- 158 | 159 | 160 | sfileLike :: File FileInfo -> (Bool, File FileInfo) 161 | sfileLike f@RegFile{} = (True, f) 162 | sfileLike f@BlockDev{} = (True, f) 163 | sfileLike f@CharDev{} = (True, f) 164 | sfileLike f@NamedPipe{} = (True, f) 165 | sfileLike f@Socket{} = (True, f) 166 | sfileLike f = fileLikeSym f 167 | 168 | 169 | fileLike :: File FileInfo -> (Bool, File FileInfo) 170 | fileLike f@RegFile {} = (True, f) 171 | fileLike f@BlockDev{} = (True, f) 172 | fileLike f@CharDev{} = (True, f) 173 | fileLike f@NamedPipe{} = (True, f) 174 | fileLike f@Socket{} = (True, f) 175 | fileLike f = (False, f) 176 | 177 | 178 | sdir :: File FileInfo -> (Bool, File FileInfo) 179 | sdir f@SymLink{ sdest = (Just s@SymLink{} )} 180 | -- we have to follow a chain of symlinks here, but 181 | -- return only the very first level 182 | -- TODO: this is probably obsolete now 183 | = case sdir s of 184 | (True, _) -> (True, f) 185 | _ -> (False, f) 186 | sdir f@SymLink{ sdest = Just Dir{} } 187 | = (True, f) 188 | sdir f@Dir{} = (True, f) 189 | sdir f = (False, f) 190 | 191 | 192 | -- |Matches on any non-directory kind of files, excluding symlinks. 193 | pattern FileLike :: File FileInfo -> File FileInfo 194 | pattern FileLike f <- (fileLike -> (True, f)) 195 | 196 | -- |Matches a list of directories or symlinks pointing to directories. 197 | pattern DirList :: [File FileInfo] -> [File FileInfo] 198 | pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs) 199 | -> (True, fs)) 200 | 201 | -- |Matches a list of any non-directory kind of files or symlinks 202 | -- pointing to such. 203 | pattern FileLikeList :: [File FileInfo] -> [File FileInfo] 204 | pattern FileLikeList fs <- (\fs -> (and 205 | . fmap (fst . sfileLike) 206 | $ fs, fs) -> (True, fs)) 207 | 208 | 209 | 210 | ---- Symlinks ---- 211 | 212 | 213 | brokenSymlink :: File FileInfo -> (Bool, File FileInfo) 214 | brokenSymlink f = (isBrokenSymlink f, f) 215 | 216 | 217 | fileLikeSym :: File FileInfo -> (Bool, File FileInfo) 218 | fileLikeSym f@SymLink{ sdest = Just s@SymLink{} } 219 | = case fileLikeSym s of 220 | (True, _) -> (True, f) 221 | _ -> (False, f) 222 | fileLikeSym f@SymLink{ sdest = Just RegFile{} } = (True, f) 223 | fileLikeSym f@SymLink{ sdest = Just BlockDev{} } = (True, f) 224 | fileLikeSym f@SymLink{ sdest = Just CharDev{} } = (True, f) 225 | fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f) 226 | fileLikeSym f@SymLink{ sdest = Just Socket{} } = (True, f) 227 | fileLikeSym f = (False, f) 228 | 229 | 230 | dirSym :: File FileInfo -> (Bool, File FileInfo) 231 | dirSym f@SymLink{ sdest = Just s@SymLink{} } 232 | = case dirSym s of 233 | (True, _) -> (True, f) 234 | _ -> (False, f) 235 | dirSym f@SymLink{ sdest = Just Dir{} } = (True, f) 236 | dirSym f = (False, f) 237 | 238 | 239 | -- |Matches on symlinks pointing to file-like files only. 240 | pattern FileLikeSym :: File FileInfo -> File FileInfo 241 | pattern FileLikeSym f <- (fileLikeSym -> (True, f)) 242 | 243 | -- |Matches on broken symbolic links. 244 | pattern BrokenSymlink :: File FileInfo -> File FileInfo 245 | pattern BrokenSymlink f <- (brokenSymlink -> (True, f)) 246 | 247 | 248 | -- |Matches on directories or symlinks pointing to directories. 249 | -- If the symlink is pointing to a symlink pointing to a directory, then 250 | -- it will return True, but also return the first element in the symlink- 251 | -- chain, not the last. 252 | pattern DirOrSym :: File FileInfo -> File FileInfo 253 | pattern DirOrSym f <- (sdir -> (True, f)) 254 | 255 | -- |Matches on symlinks pointing to directories only. 256 | pattern DirSym :: File FileInfo -> File FileInfo 257 | pattern DirSym f <- (dirSym -> (True, f)) 258 | 259 | -- |Matches on any non-directory kind of files or symlinks pointing to 260 | -- such. 261 | -- If the symlink is pointing to a symlink pointing to such a file, then 262 | -- it will return True, but also return the first element in the symlink- 263 | -- chain, not the last. 264 | pattern FileLikeOrSym :: File FileInfo -> File FileInfo 265 | pattern FileLikeOrSym f <- (sfileLike -> (True, f)) 266 | 267 | 268 | 269 | 270 | 271 | ----------------- 272 | --[ INSTANCES ]-- 273 | ----------------- 274 | 275 | 276 | -- | First compare constructors: Failed < Dir < File... 277 | -- Then compare `name`... 278 | -- Then compare free variable parameter of `File` constructors 279 | instance Ord (File FileInfo) where 280 | compare (RegFile n a) (RegFile n' a') = 281 | case compare n n' of 282 | EQ -> compare a a' 283 | el -> el 284 | compare (Dir n b) (Dir n' b') = 285 | case compare n n' of 286 | EQ -> compare b b' 287 | el -> el 288 | -- after comparing above we can hand off to shape ord function: 289 | compare d d' = comparingConstr d d' 290 | 291 | 292 | 293 | 294 | 295 | ---------------------------- 296 | --[ HIGH LEVEL FUNCTIONS ]-- 297 | ---------------------------- 298 | 299 | 300 | 301 | -- |Reads a file or directory Path into an `AnchoredFile`, filling the free 302 | -- variables via the given function. 303 | pathToFile :: (Path Abs -> IO a) 304 | -> Path Abs 305 | -> IO (File a) 306 | pathToFile ff p = do 307 | fs <- PF.getSymbolicLinkStatus (P.toFilePath p) 308 | fv <- ff p 309 | constructFile fs fv p 310 | where 311 | constructFile fs fv p' 312 | | PF.isSymbolicLink fs = do 313 | -- symlink madness, we need to make sure we save the correct 314 | -- File 315 | x <- PF.readSymbolicLink (P.fromAbs p') 316 | resolvedSyml <- handleIOError (\_ -> return Nothing) $ do 317 | -- watch out, we call from 'filepath' here, but it is safe 318 | let sfp = (P.fromAbs . P.dirname $ p') x 319 | rsfp <- realpath sfp 320 | f <- pathToFile ff =<< P.parseAbs rsfp 321 | return $ Just f 322 | return $ SymLink p' fv resolvedSyml x 323 | | PF.isDirectory fs = return $ Dir p' fv 324 | | PF.isRegularFile fs = return $ RegFile p' fv 325 | | PF.isBlockDevice fs = return $ BlockDev p' fv 326 | | PF.isCharacterDevice fs = return $ CharDev p' fv 327 | | PF.isNamedPipe fs = return $ NamedPipe p' fv 328 | | PF.isSocket fs = return $ Socket p' fv 329 | | otherwise = ioError $ userError "Unknown filetype!" 330 | 331 | 332 | -- |Get the contents of a given directory and return them as a list 333 | -- of `AnchoredFile`. 334 | readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable 335 | -> Path Abs -- ^ path to read 336 | -> IO [File a] 337 | readDirectoryContents ff p = do 338 | files <- getDirsFiles p 339 | mapM (pathToFile ff) files 340 | 341 | 342 | -- |A variant of `readDirectoryContents` where the second argument 343 | -- is a `File`. If a non-directory is passed returns an empty list. 344 | getContents :: (Path Abs -> IO a) 345 | -> File FileInfo 346 | -> IO [File a] 347 | getContents ff (DirOrSym af) 348 | = readDirectoryContents ff (path af) 349 | getContents _ _ = return [] 350 | 351 | 352 | 353 | -- |Go up one directory in the filesystem hierarchy. 354 | goUp :: File FileInfo -> IO (File FileInfo) 355 | goUp file = pathToFile getFileInfo (P.dirname . path $ file) 356 | 357 | 358 | -- |Go up one directory in the filesystem hierarchy. 359 | goUp' :: Path Abs -> IO (File FileInfo) 360 | goUp' fp = pathToFile getFileInfo $ P.dirname fp 361 | 362 | 363 | 364 | 365 | ----------------- 366 | --[ UTILITIES ]-- 367 | ----------------- 368 | 369 | 370 | 371 | 372 | 373 | ---- ORDERING AND EQUALITY ---- 374 | 375 | 376 | -- HELPER: a non-recursive comparison 377 | comparingConstr :: File FileInfo -> File FileInfo -> Ordering 378 | comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT 379 | comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT 380 | -- else compare on the names of constructors that are the same, without 381 | -- looking at the contents of Dir constructors: 382 | comparingConstr t t' = compare (path t) (path t') 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | --------------- 391 | --[ HELPERS ]-- 392 | --------------- 393 | 394 | 395 | ---- CONSTRUCTOR IDENTIFIERS ---- 396 | 397 | isFileC :: File a -> Bool 398 | isFileC RegFile{} = True 399 | isFileC _ = False 400 | 401 | 402 | isDirC :: File a -> Bool 403 | isDirC Dir{} = True 404 | isDirC _ = False 405 | 406 | 407 | isSymC :: File a -> Bool 408 | isSymC SymLink{} = True 409 | isSymC _ = False 410 | 411 | 412 | isBlockC :: File a -> Bool 413 | isBlockC BlockDev{} = True 414 | isBlockC _ = False 415 | 416 | 417 | isCharC :: File a -> Bool 418 | isCharC CharDev{} = True 419 | isCharC _ = False 420 | 421 | 422 | isNamedC :: File a -> Bool 423 | isNamedC NamedPipe{} = True 424 | isNamedC _ = False 425 | 426 | 427 | isSocketC :: File a -> Bool 428 | isSocketC Socket{} = True 429 | isSocketC _ = False 430 | 431 | 432 | 433 | 434 | ---- IO HELPERS: ---- 435 | 436 | 437 | 438 | -- |Gets all file information. 439 | getFileInfo :: Path Abs -> IO FileInfo 440 | getFileInfo fp = do 441 | fs <- PF.getSymbolicLinkStatus (P.fromAbs fp) 442 | return $ FileInfo 443 | (PF.deviceID fs) 444 | (PF.fileID fs) 445 | (PF.fileMode fs) 446 | (PF.linkCount fs) 447 | (PF.fileOwner fs) 448 | (PF.fileGroup fs) 449 | (PF.specialDeviceID fs) 450 | (PF.fileSize fs) 451 | (PF.accessTime fs) 452 | (PF.modificationTime fs) 453 | (PF.statusChangeTime fs) 454 | (PF.accessTimeHiRes fs) 455 | (PF.modificationTimeHiRes fs) 456 | (PF.statusChangeTimeHiRes fs) 457 | 458 | 459 | 460 | 461 | 462 | ---- SYMLINK HELPERS: ---- 463 | 464 | 465 | -- |Checks if a symlink is broken by examining the constructor of the 466 | -- symlink destination. 467 | -- 468 | -- When called on a non-symlink, returns False. 469 | isBrokenSymlink :: File FileInfo -> Bool 470 | isBrokenSymlink (SymLink _ _ Nothing _) = True 471 | isBrokenSymlink _ = False 472 | 473 | 474 | 475 | 476 | ---- PACKERS: ---- 477 | 478 | 479 | -- |Pack the modification time into a string. 480 | packModTime :: File FileInfo 481 | -> String 482 | packModTime = epochToString . modificationTime . fvar 483 | 484 | 485 | -- |Pack the modification time into a string. 486 | packAccessTime :: File FileInfo 487 | -> String 488 | packAccessTime = epochToString . accessTime . fvar 489 | 490 | 491 | epochToString :: EpochTime -> String 492 | epochToString = show . posixSecondsToUTCTime . realToFrac 493 | 494 | 495 | -- |Pack the permissions into a string, similar to what "ls -l" does. 496 | packPermissions :: File FileInfo 497 | -> String 498 | packPermissions file = (pStr . fileMode) . fvar $ file 499 | where 500 | pStr :: FileMode -> String 501 | pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr 502 | where 503 | typeModeStr = case file of 504 | Dir {} -> "d" 505 | RegFile {} -> "-" 506 | SymLink {} -> "l" 507 | BlockDev {} -> "b" 508 | CharDev {} -> "c" 509 | NamedPipe {} -> "p" 510 | Socket {} -> "s" 511 | ownerModeStr = hasFmStr PF.ownerReadMode "r" 512 | ++ hasFmStr PF.ownerWriteMode "w" 513 | ++ hasFmStr PF.ownerExecuteMode "x" 514 | groupModeStr = hasFmStr PF.groupReadMode "r" 515 | ++ hasFmStr PF.groupWriteMode "w" 516 | ++ hasFmStr PF.groupExecuteMode "x" 517 | otherModeStr = hasFmStr PF.otherReadMode "r" 518 | ++ hasFmStr PF.otherWriteMode "w" 519 | ++ hasFmStr PF.otherExecuteMode "x" 520 | hasFmStr fm str 521 | | hasFM fm = str 522 | | otherwise = "-" 523 | hasFM fm = ffm `PF.intersectFileModes` fm == fm 524 | 525 | 526 | packFileType :: File a -> String 527 | packFileType file = case file of 528 | Dir {} -> "Directory" 529 | RegFile {} -> "Regular File" 530 | SymLink {} -> "Symbolic Link" 531 | BlockDev {} -> "Block Device" 532 | CharDev {} -> "Char Device" 533 | NamedPipe {} -> "Named Pipe" 534 | Socket {} -> "Socket" 535 | 536 | 537 | packLinkDestination :: File a -> Maybe ByteString 538 | packLinkDestination file = case file of 539 | SymLink { rawdest = dest } -> Just dest 540 | _ -> Nothing 541 | 542 | 543 | 544 | 545 | ---- OTHER: ---- 546 | 547 | 548 | getFPasStr :: File a -> String 549 | getFPasStr = toString . P.fromAbs . path 550 | 551 | -------------------------------------------------------------------------------- /src/HSFM/FileSystem/UtilTypes.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | 22 | -- |This module provides high-level IO related file operations like 23 | -- copy, delete, move and so on. It only operates on `Path Abs` which 24 | -- guarantees us well-typed paths which are absolute. 25 | -- 26 | -- Some functions are just path-safe wrappers around 27 | -- unix functions, others have stricter exception handling 28 | -- and some implement functionality that doesn't have a unix 29 | -- counterpart (like `copyDirRecursive`). 30 | -- 31 | -- Some of these operations are due to their nature not _atomic_, which 32 | -- means they may do multiple syscalls which form one context. Some 33 | -- of them also have to examine the filetypes explicitly before the 34 | -- syscalls, so a reasonable decision can be made. That means 35 | -- the result is undefined if another process changes that context 36 | -- while the non-atomic operation is still happening. However, where 37 | -- possible, as few syscalls as possible are used and the underlying 38 | -- exception handling is kept. 39 | module HSFM.FileSystem.UtilTypes where 40 | 41 | 42 | import Data.ByteString 43 | ( 44 | ByteString 45 | ) 46 | import HPath 47 | ( 48 | Path 49 | , Abs 50 | , Rel 51 | ) 52 | 53 | 54 | -- |Data type describing file operations. 55 | -- Useful to build up a list of operations or delay operations. 56 | data FileOperation = FCopy Copy 57 | | FMove Move 58 | | FDelete [Path Abs] 59 | | FOpen (Path Abs) 60 | | FExecute (Path Abs) [ByteString] 61 | | None 62 | 63 | 64 | -- |Data type describing partial or complete file copy operation. 65 | data Copy = PartialCopy [Path Abs] -- source files 66 | | Copy [Path Abs] -- source files 67 | (Path Abs) -- base destination directory 68 | 69 | 70 | -- |Data type describing partial or complete file move operation. 71 | data Move = PartialMove [Path Abs] -- source files 72 | | Move [Path Abs] -- source files 73 | (Path Abs) -- base destination directory 74 | 75 | 76 | -- |Collision modes that describe the behavior in case a file collision 77 | -- happens. 78 | data FCollisonMode = Strict -- ^ fail if the target already exists 79 | | Overwrite 80 | | OverwriteAll 81 | | Skip 82 | | Rename (Path Rel) 83 | 84 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Glib/GlibString.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | 22 | module HSFM.GUI.Glib.GlibString where 23 | 24 | 25 | import qualified Data.ByteString as BS 26 | import Data.ByteString.UTF8 27 | ( 28 | toString 29 | ) 30 | import Data.Word8 31 | ( 32 | _percent 33 | ) 34 | import Foreign.C.String 35 | ( 36 | CStringLen 37 | , CString 38 | ) 39 | import Foreign.C.Types 40 | ( 41 | CSize(..) 42 | ) 43 | import Foreign.Marshal.Utils 44 | ( 45 | maybePeek 46 | ) 47 | import Foreign.Ptr 48 | ( 49 | nullPtr 50 | , plusPtr 51 | ) 52 | import System.Glib.UTFString 53 | 54 | 55 | 56 | -- TODO: move this to its own module 57 | instance GlibString BS.ByteString where 58 | withUTFString = BS.useAsCString 59 | withUTFStringLen s f = BS.useAsCStringLen s (f . noNullPtrs) 60 | peekUTFString s = do 61 | len <- c_strlen s 62 | BS.packCStringLen (s, fromIntegral len) 63 | maybePeekUTFString = maybePeek peekUTFString 64 | peekUTFStringLen = BS.packCStringLen 65 | newUTFString = newUTFString . toString 66 | newUTFStringLen = newUTFStringLen . toString 67 | genUTFOfs = genUTFOfs . toString 68 | stringLength = BS.length 69 | unPrintf s = BS.intercalate (BS.pack [_percent, _percent]) (BS.split _percent s) 70 | 71 | 72 | foreign import ccall unsafe "string.h strlen" c_strlen 73 | :: CString -> IO CSize 74 | 75 | 76 | noNullPtrs :: CStringLen -> CStringLen 77 | noNullPtrs (p, 0) | p == nullPtr = (plusPtr p 1, 0) 78 | noNullPtrs s = s 79 | 80 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2015 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | module Main where 22 | 23 | 24 | import qualified Data.ByteString as BS 25 | import Data.Maybe 26 | ( 27 | fromJust 28 | , fromMaybe 29 | ) 30 | import Data.Word8 31 | import Graphics.UI.Gtk 32 | import qualified HPath as P 33 | import HSFM.FileSystem.FileType 34 | import HSFM.GUI.Gtk.Callbacks 35 | import HSFM.GUI.Gtk.Data 36 | import HSFM.GUI.Gtk.MyGUI 37 | import HSFM.GUI.Gtk.MyView 38 | import Prelude hiding(readFile) 39 | import Safe 40 | ( 41 | headDef 42 | ) 43 | import System.IO.Error 44 | ( 45 | catchIOError 46 | ) 47 | import qualified System.Posix.Env.ByteString as SPE 48 | 49 | slash :: BS.ByteString 50 | slash = BS.singleton _slash 51 | 52 | main :: IO () 53 | main = do 54 | args <- SPE.getArgs 55 | let mdir = fromMaybe (fromJust $ P.parseAbs slash) 56 | (P.parseAbs . headDef slash $ args) 57 | 58 | file <- catchIOError (pathToFile getFileInfo mdir) $ 59 | \_ -> pathToFile getFileInfo . fromJust $ P.parseAbs slash 60 | 61 | _ <- initGUI 62 | mygui <- createMyGUI 63 | _ <- newTab mygui (notebook1 mygui) createTreeView file (-1) 64 | _ <- newTab mygui (notebook2 mygui) createTreeView file (-1) 65 | 66 | setGUICallbacks mygui 67 | 68 | widgetShowAll (rootWin mygui) 69 | 70 | _ <- mainGUI 71 | return () 72 | 73 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Callbacks.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# LANGUAGE TupleSections #-} 20 | {-# OPTIONS_HADDOCK ignore-exports #-} 21 | 22 | module HSFM.GUI.Gtk.Callbacks where 23 | 24 | 25 | import Control.Concurrent.STM 26 | ( 27 | readTVarIO 28 | ) 29 | import Control.Exception 30 | ( 31 | throwIO 32 | ) 33 | import Control.Monad 34 | ( 35 | forM 36 | , forM_ 37 | , join 38 | , void 39 | , when 40 | ) 41 | import Control.Monad.IfElse 42 | import Control.Monad.IO.Class 43 | ( 44 | liftIO 45 | ) 46 | import Control.Monad.Loops 47 | ( 48 | iterateUntil 49 | ) 50 | import Data.ByteString 51 | ( 52 | ByteString 53 | ) 54 | import Data.ByteString.UTF8 55 | ( 56 | fromString 57 | , toString 58 | ) 59 | import Data.Foldable 60 | ( 61 | for_ 62 | ) 63 | import Graphics.UI.Gtk 64 | import qualified HPath as P 65 | import HPath 66 | ( 67 | fromAbs 68 | , Abs 69 | , Path 70 | ) 71 | import HPath.IO 72 | import HPath.IO.Errors 73 | import HSFM.FileSystem.FileType 74 | import HSFM.FileSystem.UtilTypes 75 | import HSFM.GUI.Gtk.Callbacks.Utils 76 | import HSFM.GUI.Gtk.Data 77 | import HSFM.GUI.Gtk.Dialogs 78 | import HSFM.GUI.Gtk.MyView 79 | import HSFM.GUI.Gtk.Plugins 80 | import HSFM.GUI.Gtk.Settings 81 | import HSFM.GUI.Gtk.Utils 82 | import HSFM.History 83 | import HSFM.Settings 84 | import HSFM.Utils.IO 85 | import Prelude hiding(readFile) 86 | import System.Glib.UTFString 87 | ( 88 | glibToString 89 | ) 90 | import qualified System.Posix.Process.ByteString as SPP 91 | import System.Posix.Types 92 | ( 93 | ProcessID 94 | ) 95 | import Control.Concurrent.MVar 96 | ( 97 | putMVar 98 | , readMVar 99 | , takeMVar 100 | ) 101 | import Paths_hsfm 102 | ( 103 | getDataFileName 104 | ) 105 | 106 | 107 | 108 | 109 | ----------------- 110 | --[ Callbacks ]-- 111 | ----------------- 112 | 113 | 114 | 115 | 116 | ---- MAIN CALLBACK ENTRYPOINT ---- 117 | 118 | 119 | -- |Set callbacks for the whole gui, on hotkeys, events and stuff. 120 | setGUICallbacks :: MyGUI -> IO () 121 | setGUICallbacks mygui = do 122 | 123 | -- notebook toggle buttons 124 | _ <- leftNbBtn mygui `on` toggled $ do 125 | isPressed <- toggleButtonGetActive $ leftNbBtn mygui 126 | if isPressed then widgetShow $ notebook1 mygui 127 | else widgetHide $ notebook1 mygui 128 | 129 | _ <- rightNbBtn mygui `on` toggled $ do 130 | isPressed <- toggleButtonGetActive $ rightNbBtn mygui 131 | if isPressed then widgetShow $ notebook2 mygui 132 | else widgetHide $ notebook2 mygui 133 | 134 | -- statusbar 135 | _ <- clearStatusBar mygui `on` buttonActivated $ do 136 | popStatusbar mygui 137 | writeTVarIO (operationBuffer mygui) None 138 | 139 | -- menubar-file 140 | _ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $ 141 | mainQuit 142 | 143 | -- menubar-help 144 | _ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $ 145 | liftIO showAboutDialog 146 | return () 147 | 148 | -- key events 149 | _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do 150 | QuitModifier <- eventModifier 151 | QuitKey <- fmap glibToString eventKeyName 152 | liftIO mainQuit 153 | 154 | return () 155 | 156 | 157 | -- |Set callbacks specific to a given view, on hotkeys, events and stuff. 158 | setViewCallbacks :: MyGUI -> MyView -> IO () 159 | setViewCallbacks mygui myview = do 160 | view' <- readTVarIO $ view myview 161 | case view' of 162 | fmv@(FMTreeView treeView) -> do 163 | _ <- treeView `on` rowActivated 164 | $ (\_ _ -> withItems mygui myview open) 165 | 166 | -- drag events 167 | _ <- treeView `on` dragBegin $ 168 | \_ -> withItems mygui myview moveInit 169 | _ <- treeView `on` dragDrop $ 170 | \dc p ts -> do 171 | p' <- treeViewConvertWidgetToTreeCoords treeView p 172 | mpath <- treeViewGetPathAtPos treeView p' 173 | case mpath of 174 | Nothing -> do 175 | dragFinish dc False False ts 176 | return False 177 | Just _ -> do 178 | atom <- atomNew ("HSFM" :: String) 179 | dragGetData treeView dc atom ts 180 | return True 181 | _ <- treeView `on` dragDataReceived $ 182 | \dc p _ ts -> 183 | liftIO $ do 184 | signalStopEmission treeView "drag_data_received" 185 | p' <- treeViewConvertWidgetToTreeCoords treeView p 186 | mpath <- treeViewGetPathAtPos treeView p' 187 | case mpath of 188 | Nothing -> dragFinish dc False False ts 189 | Just (tp, _, _) -> do 190 | mitem <- rawPathToItem myview tp 191 | forM_ mitem $ \item -> 192 | operationFinal mygui myview (Just item) 193 | dragFinish dc True False ts 194 | 195 | commonGuiEvents fmv 196 | return () 197 | fmv@(FMIconView iconView) -> do 198 | _ <- iconView `on` itemActivated 199 | $ (\_ -> withItems mygui myview open) 200 | commonGuiEvents fmv 201 | return () 202 | where 203 | commonGuiEvents fmv = do 204 | let view = fmViewToContainer fmv 205 | 206 | -- focus events 207 | _ <- notebook1 mygui `on` setFocusChild $ \w -> 208 | case w of 209 | Nothing -> widgetSetSensitive (leftNbIcon mygui) False 210 | _ -> widgetSetSensitive (leftNbIcon mygui) True 211 | _ <- notebook2 mygui `on` setFocusChild $ \w -> 212 | case w of 213 | Nothing -> widgetSetSensitive (rightNbIcon mygui) False 214 | _ -> widgetSetSensitive (rightNbIcon mygui) True 215 | 216 | -- GUI events 217 | _ <- backViewB myview `on` buttonPressEvent $ do 218 | eb <- eventButton 219 | t <- eventTime 220 | case eb of 221 | LeftButton -> do 222 | liftIO $ void $ goHistoryBack mygui myview 223 | return True 224 | RightButton -> do 225 | his <- liftIO $ readMVar (history myview) 226 | menu <- liftIO $ mkHistoryMenuB mygui myview 227 | (backwardsHistory his) 228 | _ <- liftIO $ menuPopup menu $ Just (RightButton, t) 229 | return True 230 | _ -> return False 231 | _ <- forwardViewB myview `on` buttonPressEvent $ do 232 | eb <- eventButton 233 | t <- eventTime 234 | case eb of 235 | LeftButton -> do 236 | liftIO $ void $ goHistoryForward mygui myview 237 | return True 238 | RightButton -> do 239 | his <- liftIO $ readMVar (history myview) 240 | menu <- liftIO $ mkHistoryMenuF mygui myview 241 | (forwardHistory his) 242 | _ <- liftIO $ menuPopup menu $ Just (RightButton, t) 243 | return True 244 | _ -> return False 245 | _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview 246 | _ <- upViewB myview `on` buttonActivated $ 247 | upDir mygui myview 248 | _ <- homeViewB myview `on` buttonActivated $ 249 | goHome mygui myview 250 | _ <- refreshViewB myview `on` buttonActivated $ do 251 | cdir <- liftIO $ getCurrentDir myview 252 | refreshView mygui myview cdir 253 | 254 | -- key events 255 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 256 | ShowHiddenModifier <- eventModifier 257 | ShowHiddenKey <- fmap glibToString eventKeyName 258 | cdir <- liftIO $ getCurrentDir myview 259 | liftIO $ modifyTVarIO (settings mygui) 260 | (\x -> x { showHidden = not . showHidden $ x}) 261 | >> refreshView mygui myview cdir 262 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 263 | UpDirModifier <- eventModifier 264 | UpDirKey <- fmap glibToString eventKeyName 265 | liftIO $ upDir mygui myview 266 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 267 | HistoryBackModifier <- eventModifier 268 | HistoryBackKey <- fmap glibToString eventKeyName 269 | liftIO $ void $ goHistoryBack mygui myview 270 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 271 | HistoryForwardModifier <- eventModifier 272 | HistoryForwardKey <- fmap glibToString eventKeyName 273 | liftIO $ void $ goHistoryForward mygui myview 274 | _ <- view `on` keyPressEvent $ tryEvent $ do 275 | DeleteModifier <- eventModifier 276 | DeleteKey <- fmap glibToString eventKeyName 277 | liftIO $ withItems mygui myview del 278 | _ <- view `on` keyPressEvent $ tryEvent $ do 279 | OpenModifier <- eventModifier 280 | OpenKey <- fmap glibToString eventKeyName 281 | liftIO $ withItems mygui myview open 282 | _ <- view `on` keyPressEvent $ tryEvent $ do 283 | CopyModifier <- eventModifier 284 | CopyKey <- fmap glibToString eventKeyName 285 | liftIO $ withItems mygui myview copyInit 286 | _ <- view `on` keyPressEvent $ tryEvent $ do 287 | MoveModifier <- eventModifier 288 | MoveKey <- fmap glibToString eventKeyName 289 | liftIO $ withItems mygui myview moveInit 290 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 291 | PasteModifier <- eventModifier 292 | PasteKey <- fmap glibToString eventKeyName 293 | liftIO $ operationFinal mygui myview Nothing 294 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 295 | NewTabModifier <- eventModifier 296 | NewTabKey <- fmap glibToString eventKeyName 297 | liftIO $ void $ newTab' mygui myview 298 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 299 | CloseTabModifier <- eventModifier 300 | CloseTabKey <- fmap glibToString eventKeyName 301 | liftIO $ void $ closeTab mygui myview 302 | _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do 303 | OpenTerminalModifier <- eventModifier 304 | OpenTerminalKey <- fmap glibToString eventKeyName 305 | liftIO $ void $ openTerminalHere myview 306 | 307 | -- mouse button click 308 | _ <- view `on` buttonPressEvent $ do 309 | eb <- eventButton 310 | t <- eventTime 311 | case eb of 312 | RightButton -> do 313 | _ <- liftIO $ showPopup mygui myview t 314 | -- this is just to not screw with current selection 315 | -- on right-click 316 | -- TODO: this misbehaves under IconView 317 | (x, y) <- eventCoordinates 318 | mpath <- liftIO $ getPathAtPos fmv (x, y) 319 | case mpath of 320 | -- item under the cursor, only pass on the signal 321 | -- if the item under the cursor is not within the current 322 | -- selection 323 | (Just tp) -> do 324 | selectedTps <- liftIO $ getSelectedTreePaths mygui myview 325 | return $ elem tp selectedTps 326 | -- no item under the cursor, pass on the signal 327 | Nothing -> return False 328 | MiddleButton -> do 329 | (x, y) <- eventCoordinates 330 | mitem <- liftIO $ (getPathAtPos fmv (x, y)) 331 | >>= \mpos -> fmap join 332 | $ forM mpos (rawPathToItem myview) 333 | 334 | case mitem of 335 | -- item under the cursor, only pass on the signal 336 | -- if the item under the cursor is not within the current 337 | -- selection 338 | (Just item) -> do 339 | liftIO $ opeInNewTab mygui myview item 340 | return True 341 | -- no item under the cursor, pass on the signal 342 | Nothing -> return False 343 | 344 | OtherButton 8 -> do 345 | liftIO $ void $ goHistoryBack mygui myview 346 | return False 347 | OtherButton 9 -> do 348 | liftIO $ void $ goHistoryForward mygui myview 349 | return False 350 | -- not right-click, so pass on the signal 351 | _ -> return False 352 | 353 | return () 354 | getPathAtPos fmv (x, y) = 355 | case fmv of 356 | FMTreeView treeView -> do 357 | mp <- treeViewGetPathAtPos treeView (round x, round y) 358 | return $ fmap (\(p, _, _) -> p) mp 359 | FMIconView iconView -> 360 | fmap (\tp -> if null tp then Nothing else Just tp) 361 | $ iconViewGetPathAtPos iconView (round x) (round y) 362 | 363 | 364 | 365 | 366 | ---- OTHER ---- 367 | 368 | 369 | openTerminalHere :: MyView -> IO ProcessID 370 | openTerminalHere myview = do 371 | cwd <- (P.fromAbs . path) <$> getCurrentDir myview 372 | SPP.forkProcess $ terminalCommand cwd 373 | 374 | 375 | 376 | 377 | ---- TAB OPERATIONS ---- 378 | 379 | 380 | -- |Closes the current tab, but only if there is more than one tab. 381 | closeTab :: MyGUI -> MyView -> IO () 382 | closeTab _ myview = do 383 | n <- notebookGetNPages (notebook myview) 384 | when (n > 1) $ void $ destroyView myview 385 | 386 | 387 | newTab' :: MyGUI -> MyView -> IO () 388 | newTab' mygui myview = do 389 | cwd <- getCurrentDir myview 390 | void $ withErrorDialog 391 | $ newTab mygui (notebook myview) createTreeView cwd (-1) 392 | 393 | 394 | opeInNewTab :: MyGUI -> MyView -> Item -> IO () 395 | opeInNewTab mygui myview item@(DirOrSym _) = 396 | void $ withErrorDialog 397 | $ newTab mygui (notebook myview) createTreeView item (-1) 398 | opeInNewTab _ _ _ = return () 399 | 400 | 401 | 402 | ---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ---- 403 | 404 | 405 | -- |Supposed to be used with 'withRows'. Deletes a file or directory. 406 | del :: [Item] -> MyGUI -> MyView -> IO () 407 | del [item] _ _ = withErrorDialog $ do 408 | let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?" 409 | withConfirmationDialog cmsg 410 | $ easyDelete . path $ item 411 | -- this throws on the first error that occurs 412 | del items@(_:_) _ _ = withErrorDialog $ do 413 | let cmsg = "Really delete " ++ show (length items) ++ " files?" 414 | withConfirmationDialog cmsg 415 | $ forM_ items $ \item -> easyDelete . path $ item 416 | del _ _ _ = withErrorDialog 417 | . ioError $ userError 418 | "Operation not supported on multiple files" 419 | 420 | 421 | -- |Initializes a file move operation. 422 | moveInit :: [Item] -> MyGUI -> MyView -> IO () 423 | moveInit items@(_:_) mygui _ = do 424 | writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items) 425 | let sbmsg = case items of 426 | (item:[]) -> "Move buffer: " ++ getFPasStr item 427 | _ -> "Move buffer: " ++ (show . length $ items) 428 | ++ " items" 429 | popStatusbar mygui 430 | void $ pushStatusBar mygui sbmsg 431 | moveInit _ _ _ = withErrorDialog 432 | . ioError $ userError 433 | "No file selected!" 434 | 435 | -- |Supposed to be used with 'withRows'. Initializes a file copy operation. 436 | copyInit :: [Item] -> MyGUI -> MyView -> IO () 437 | copyInit items@(_:_) mygui _ = do 438 | writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items) 439 | let sbmsg = case items of 440 | (item:[]) -> "Copy buffer: " ++ getFPasStr item 441 | _ -> "Copy buffer: " ++ (show . length $ items) 442 | ++ " items" 443 | popStatusbar mygui 444 | void $ pushStatusBar mygui sbmsg 445 | copyInit _ _ _ = withErrorDialog 446 | . ioError $ userError 447 | "No file selected!" 448 | 449 | 450 | -- |Finalizes a file operation, such as copy or move. 451 | operationFinal :: MyGUI -> MyView -> Maybe Item -> IO () 452 | operationFinal mygui myview mitem = withErrorDialog $ do 453 | op <- readTVarIO (operationBuffer mygui) 454 | cdir <- case mitem of 455 | Nothing -> path <$> getCurrentDir myview 456 | Just x -> return $ path x 457 | case op of 458 | FMove (PartialMove s) -> do 459 | let cmsg = "Really move " ++ imsg s 460 | ++ " to \"" ++ toString (P.fromAbs cdir) 461 | ++ "\"?" 462 | withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir) 463 | popStatusbar mygui 464 | writeTVarIO (operationBuffer mygui) None 465 | FCopy (PartialCopy s) -> do 466 | let cmsg = "Really copy " ++ imsg s 467 | ++ " to \"" ++ toString (P.fromAbs cdir) 468 | ++ "\"?" 469 | withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir) 470 | _ -> return () 471 | where 472 | imsg s = case s of 473 | (item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\"" 474 | items -> (show . length $ items) ++ " items" 475 | 476 | 477 | -- |Create a new file. 478 | newFile :: MyGUI -> MyView -> IO () 479 | newFile _ myview = withErrorDialog $ do 480 | mfn <- textInputDialog "Enter file name" ("" :: String) 481 | let pmfn = P.parseRel =<< fromString <$> mfn 482 | for_ pmfn $ \fn -> do 483 | cdir <- getCurrentDir myview 484 | createRegularFile newFilePerms (path cdir P. fn) 485 | 486 | 487 | -- |Create a new directory. 488 | newDir :: MyGUI -> MyView -> IO () 489 | newDir _ myview = withErrorDialog $ do 490 | mfn <- textInputDialog "Enter directory name" ("" :: String) 491 | let pmfn = P.parseRel =<< fromString <$> mfn 492 | for_ pmfn $ \fn -> do 493 | cdir <- getCurrentDir myview 494 | createDir newDirPerms (path cdir P. fn) 495 | 496 | 497 | renameF :: [Item] -> MyGUI -> MyView -> IO () 498 | renameF [item] _ _ = withErrorDialog $ do 499 | iname <- P.fromRel <$> (P.basename $ path item) 500 | mfn <- textInputDialog "Enter new file name" (iname :: ByteString) 501 | let pmfn = P.parseRel =<< fromString <$> mfn 502 | for_ pmfn $ \fn -> do 503 | let cmsg = "Really rename \"" ++ getFPasStr item 504 | ++ "\"" ++ " to \"" 505 | ++ toString (P.fromAbs $ (P.dirname . path $ item) 506 | P. fn) ++ "\"?" 507 | withConfirmationDialog cmsg $ 508 | HPath.IO.renameFile (path item) 509 | ((P.dirname $ path item) P. fn) 510 | renameF _ _ _ = withErrorDialog 511 | . ioError $ userError 512 | "Operation not supported on multiple files" 513 | 514 | 515 | 516 | 517 | ---- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ---- 518 | 519 | 520 | -- |Go to the url given at the 'urlBar' and visualize it in the given 521 | -- treeView. 522 | -- 523 | -- If the url is invalid, does nothing. 524 | urlGoTo :: MyGUI -> MyView -> IO () 525 | urlGoTo mygui myview = withErrorDialog $ do 526 | fp <- entryGetText (urlBar myview) 527 | forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' -> 528 | whenM (canOpenDirectory fp') 529 | (goDir True mygui myview =<< (pathToFile getFileInfo $ fp')) 530 | 531 | 532 | goHome :: MyGUI -> MyView -> IO () 533 | goHome mygui myview = withErrorDialog $ do 534 | homedir <- home 535 | forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' -> 536 | whenM (canOpenDirectory fp') 537 | (goDir True mygui myview =<< (pathToFile getFileInfo $ fp')) 538 | 539 | 540 | -- |Execute a given file. 541 | execute :: [Item] -> MyGUI -> MyView -> IO () 542 | execute [item] _ _ = withErrorDialog $ 543 | void $ executeFile (path item) [] 544 | execute _ _ _ = withErrorDialog 545 | . ioError $ userError 546 | "Operation not supported on multiple files" 547 | 548 | 549 | -- |Supposed to be used with 'withRows'. Opens a file or directory. 550 | open :: [Item] -> MyGUI -> MyView -> IO () 551 | open [item] mygui myview = withErrorDialog $ 552 | case item of 553 | DirOrSym r -> do 554 | nv <- pathToFile getFileInfo $ path r 555 | goDir True mygui myview nv 556 | r -> 557 | void $ openFile . path $ r 558 | open items mygui myview = do 559 | let dirs = filter (fst . sdir) items 560 | files = filter (fst . sfileLike) items 561 | forM_ dirs (withErrorDialog . opeInNewTab mygui myview) 562 | forM_ files (withErrorDialog . openFile . path) 563 | 564 | 565 | -- |Go up one directory and visualize it in the treeView. 566 | upDir :: MyGUI -> MyView -> IO () 567 | upDir mygui myview = withErrorDialog $ do 568 | cdir <- getCurrentDir myview 569 | nv <- goUp cdir 570 | goDir True mygui myview nv 571 | 572 | 573 | 574 | 575 | ---- HISTORY CALLBACKS ---- 576 | 577 | 578 | -- |Go "back" in the history. 579 | goHistoryBack :: MyGUI -> MyView -> IO (Path Abs) 580 | goHistoryBack mygui myview = do 581 | hs <- takeMVar (history myview) 582 | let nhs = historyBack hs 583 | putMVar (history myview) nhs 584 | nv <- pathToFile getFileInfo $ currentDir nhs 585 | goDir False mygui myview nv 586 | return $ currentDir nhs 587 | 588 | 589 | -- |Go "forward" in the history. 590 | goHistoryForward :: MyGUI -> MyView -> IO (Path Abs) 591 | goHistoryForward mygui myview = do 592 | hs <- takeMVar (history myview) 593 | let nhs = historyForward hs 594 | putMVar (history myview) nhs 595 | nv <- pathToFile getFileInfo $ currentDir nhs 596 | goDir False mygui myview nv 597 | return $ currentDir nhs 598 | 599 | 600 | -- |Show backwards history in a drop-down menu, depending on the input. 601 | mkHistoryMenuB :: MyGUI -> MyView -> [Path Abs] -> IO Menu 602 | mkHistoryMenuB mygui myview hs = do 603 | menu <- menuNew 604 | menuitems <- forM hs $ \p -> do 605 | item <- menuItemNewWithLabel (fromAbs p) 606 | _ <- item `on` menuItemActivated $ 607 | void $ iterateUntil (== p) (goHistoryBack mygui myview) 608 | return item 609 | forM_ menuitems $ \item -> menuShellAppend menu item 610 | widgetShowAll menu 611 | return menu 612 | 613 | 614 | -- |Show forward history in a drop-down menu, depending on the input. 615 | mkHistoryMenuF :: MyGUI -> MyView -> [Path Abs] -> IO Menu 616 | mkHistoryMenuF mygui myview hs = do 617 | menu <- menuNew 618 | menuitems <- forM hs $ \p -> do 619 | item <- menuItemNewWithLabel (fromAbs p) 620 | _ <- item `on` menuItemActivated $ 621 | void $ iterateUntil (== p) (goHistoryForward mygui myview) 622 | return item 623 | forM_ menuitems $ \item -> menuShellAppend menu item 624 | widgetShowAll menu 625 | return menu 626 | 627 | 628 | 629 | 630 | ---- RIGHTCLICK CALLBACKS ---- 631 | 632 | 633 | -- |TODO: hopefully this does not leak 634 | showPopup :: MyGUI -> MyView -> TimeStamp -> IO () 635 | showPopup mygui myview t 636 | | null myplugins = return () 637 | | otherwise = do 638 | 639 | rcmenu <- doRcMenu 640 | 641 | -- add common callbacks 642 | _ <- (\_ -> rcFileOpen rcmenu) myview `on` menuItemActivated $ 643 | liftIO $ withItems mygui myview open 644 | _ <- (rcFileExecute rcmenu) `on` menuItemActivated $ 645 | liftIO $ withItems mygui myview execute 646 | _ <- (rcFileNewRegFile rcmenu) `on` menuItemActivated $ 647 | liftIO $ newFile mygui myview 648 | _ <- (rcFileNewDir rcmenu) `on` menuItemActivated $ 649 | liftIO $ newDir mygui myview 650 | _ <- (rcFileNewTab rcmenu) `on` menuItemActivated $ 651 | liftIO $ newTab' mygui myview 652 | _ <- (rcFileNewTerm rcmenu) `on` menuItemActivated $ 653 | liftIO $ void $ openTerminalHere myview 654 | _ <- (rcFileCopy rcmenu) `on` menuItemActivated $ 655 | liftIO $ withItems mygui myview copyInit 656 | _ <- (rcFileRename rcmenu) `on` menuItemActivated $ 657 | liftIO $ withItems mygui myview renameF 658 | _ <- (rcFilePaste rcmenu) `on` menuItemActivated $ 659 | liftIO $ operationFinal mygui myview Nothing 660 | _ <- (rcFileDelete rcmenu) `on` menuItemActivated $ 661 | liftIO $ withItems mygui myview del 662 | _ <- (rcFileProperty rcmenu) `on` menuItemActivated $ 663 | liftIO $ withItems mygui myview showFilePropertyDialog 664 | _ <- (rcFileCut rcmenu) `on` menuItemActivated $ 665 | liftIO $ withItems mygui myview moveInit 666 | _ <- (rcFileIconView rcmenu) `on` menuItemActivated $ 667 | liftIO $ switchView mygui myview createIconView 668 | _ <- (rcFileTreeView rcmenu) `on` menuItemActivated $ 669 | liftIO $ switchView mygui myview createTreeView 670 | 671 | 672 | -- add another plugin separator after the existing one 673 | -- where we want to place our plugins 674 | sep2 <- separatorMenuItemNew 675 | widgetShow sep2 676 | 677 | menuShellInsert (rcMenu rcmenu) sep2 insertPos 678 | 679 | plugins <- forM myplugins $ \(ma, mb, mc) -> fmap (, mb, mc) ma 680 | -- need to reverse plugins list so the order is right 681 | forM_ (reverse plugins) $ \(plugin, filter', cb) -> do 682 | showItem <- withItems mygui myview filter' 683 | 684 | menuShellInsert (rcMenu rcmenu) plugin insertPos 685 | when showItem $ widgetShow plugin 686 | -- init callback 687 | plugin `on` menuItemActivated $ withItems mygui myview cb 688 | 689 | menuPopup (rcMenu rcmenu) $ Just (RightButton, t) 690 | where 691 | doRcMenu = do 692 | builder <- builderNew 693 | builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" 694 | 695 | -- create static right-click menu 696 | rcMenu <- builderGetObject builder castToMenu 697 | (fromString "rcMenu") 698 | rcFileOpen <- builderGetObject builder castToImageMenuItem 699 | (fromString "rcFileOpen") 700 | rcFileExecute <- builderGetObject builder castToImageMenuItem 701 | (fromString "rcFileExecute") 702 | rcFileNewRegFile <- builderGetObject builder castToImageMenuItem 703 | (fromString "rcFileNewRegFile") 704 | rcFileNewDir <- builderGetObject builder castToImageMenuItem 705 | (fromString "rcFileNewDir") 706 | rcFileNewTab <- builderGetObject builder castToImageMenuItem 707 | (fromString "rcFileNewTab") 708 | rcFileNewTerm <- builderGetObject builder castToImageMenuItem 709 | (fromString "rcFileNewTerm") 710 | rcFileCut <- builderGetObject builder castToImageMenuItem 711 | (fromString "rcFileCut") 712 | rcFileCopy <- builderGetObject builder castToImageMenuItem 713 | (fromString "rcFileCopy") 714 | rcFileRename <- builderGetObject builder castToImageMenuItem 715 | (fromString "rcFileRename") 716 | rcFilePaste <- builderGetObject builder castToImageMenuItem 717 | (fromString "rcFilePaste") 718 | rcFileDelete <- builderGetObject builder castToImageMenuItem 719 | (fromString "rcFileDelete") 720 | rcFileProperty <- builderGetObject builder castToImageMenuItem 721 | (fromString "rcFileProperty") 722 | rcFileIconView <- builderGetObject builder castToImageMenuItem 723 | (fromString "rcFileIconView") 724 | rcFileTreeView <- builderGetObject builder castToImageMenuItem 725 | (fromString "rcFileTreeView") 726 | 727 | return $ MkRightClickMenu {..} 728 | 729 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Callbacks.hs-boot: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | 20 | module HSFM.GUI.Gtk.Callbacks where 21 | 22 | import HSFM.GUI.Gtk.Data 23 | 24 | 25 | setViewCallbacks :: MyGUI -> MyView -> IO () 26 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Callbacks/Utils.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | {-# OPTIONS_HADDOCK ignore-exports #-} 21 | 22 | module HSFM.GUI.Gtk.Callbacks.Utils where 23 | 24 | 25 | 26 | import Control.Monad 27 | ( 28 | forM_ 29 | , when 30 | ) 31 | import Data.Foldable 32 | ( 33 | for_ 34 | ) 35 | import Data.Maybe 36 | ( 37 | fromJust 38 | ) 39 | import GHC.IO.Exception 40 | ( 41 | IOErrorType(..) 42 | ) 43 | import Graphics.UI.Gtk 44 | import qualified HPath as P 45 | import HPath.IO 46 | import HPath.IO.Errors 47 | import HSFM.FileSystem.FileType 48 | import qualified HSFM.FileSystem.UtilTypes as UT 49 | import HSFM.GUI.Gtk.Data 50 | import HSFM.GUI.Gtk.Dialogs 51 | import HSFM.GUI.Gtk.MyView 52 | import HSFM.History 53 | import Prelude hiding(readFile) 54 | import Control.Concurrent.MVar 55 | ( 56 | putMVar 57 | , tryTakeMVar 58 | ) 59 | 60 | 61 | 62 | 63 | -- |Carries out a file operation with the appropriate error handling 64 | -- allowing the user to react to various exceptions with further input. 65 | doFileOperation :: UT.FileOperation -> IO () 66 | doFileOperation (UT.FCopy (UT.Copy (f':fs') to)) = 67 | _doFileOperation (f':fs') to (\p1 p2 cm -> easyCopy p1 p2 cm FailEarly) 68 | $ doFileOperation (UT.FCopy $ UT.Copy fs' to) 69 | doFileOperation (UT.FMove (UT.Move (f':fs') to)) = 70 | _doFileOperation (f':fs') to moveFile 71 | $ doFileOperation (UT.FMove $ UT.Move fs' to) 72 | doFileOperation _ = return () 73 | 74 | 75 | _doFileOperation :: [P.Path b1] 76 | -> P.Path P.Abs 77 | -> (P.Path b1 -> P.Path P.Abs -> CopyMode -> IO b) 78 | -> IO () 79 | -> IO () 80 | _doFileOperation [] _ _ _ = return () 81 | _doFileOperation (f:fs) to mc rest = do 82 | toname <- P.basename f 83 | let topath = to P. toname 84 | reactOnError (mc f topath Strict >> rest) 85 | -- TODO: how safe is 'AlreadyExists' here? 86 | [(AlreadyExists , collisionAction fileCollisionDialog topath)] 87 | [(SameFile{} , collisionAction renameDialog topath)] 88 | where 89 | collisionAction diag topath = do 90 | mcm <- diag . P.fromAbs $ topath 91 | forM_ mcm $ \cm -> case cm of 92 | UT.Overwrite -> mc f topath Overwrite >> rest 93 | UT.OverwriteAll -> forM_ (f:fs) $ \x -> do 94 | toname' <- P.basename x 95 | mc x (to P. toname') Overwrite 96 | UT.Skip -> rest 97 | UT.Rename newn -> mc f (to P. newn) Strict >> rest 98 | _ -> return () 99 | 100 | 101 | -- |Helper that is invoked for any directory change operations. 102 | goDir :: Bool -- ^ whether to update the history 103 | -> MyGUI 104 | -> MyView 105 | -> Item 106 | -> IO () 107 | goDir bhis mygui myview item = do 108 | when bhis $ do 109 | mhs <- tryTakeMVar (history myview) 110 | for_ mhs $ \hs -> do 111 | let nhs = historyNewPath (path item) hs 112 | putMVar (history myview) nhs 113 | refreshView mygui myview item 114 | 115 | -- set notebook tab label 116 | page <- notebookGetCurrentPage (notebook myview) 117 | child <- fromJust <$> notebookGetNthPage (notebook myview) page 118 | 119 | -- get the label 120 | ebox <- (castToEventBox . fromJust) 121 | <$> notebookGetTabLabel (notebook myview) child 122 | label <- (castToLabel . head) <$> containerGetChildren ebox 123 | 124 | -- set the label 125 | labelSetText label 126 | (maybe (P.fromAbs $ path item) 127 | P.fromRel $ P.basename . path $ item) 128 | 129 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Data.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | module HSFM.GUI.Gtk.Data where 22 | 23 | 24 | import Control.Concurrent.MVar 25 | ( 26 | MVar 27 | ) 28 | import Control.Concurrent.STM 29 | ( 30 | TVar 31 | ) 32 | import Graphics.UI.Gtk hiding (MenuBar) 33 | import HSFM.FileSystem.FileType 34 | import HSFM.FileSystem.UtilTypes 35 | import HSFM.History 36 | import System.INotify 37 | ( 38 | INotify 39 | ) 40 | 41 | 42 | 43 | ------------------ 44 | --[ Base Types ]-- 45 | ------------------ 46 | 47 | 48 | -- |Monolithic object passed to various GUI functions in order 49 | -- to keep the API stable and not alter the parameters too much. 50 | -- This only holds GUI widgets that are needed to be read during 51 | -- runtime. 52 | data MyGUI = MkMyGUI { 53 | -- |main Window 54 | rootWin :: !Window 55 | 56 | -- widgets on the main window 57 | , menubar :: !MenuBar 58 | , statusBar :: !Statusbar 59 | , clearStatusBar :: !Button 60 | 61 | , notebook1 :: !Notebook 62 | , leftNbBtn :: !ToggleButton 63 | , leftNbIcon :: !Image 64 | 65 | , notebook2 :: !Notebook 66 | , rightNbBtn :: !ToggleButton 67 | , rightNbIcon :: !Image 68 | 69 | -- other 70 | , fprop :: !FilePropertyGrid 71 | , settings :: !(TVar FMSettings) 72 | 73 | , operationBuffer :: !(TVar FileOperation) 74 | } 75 | 76 | 77 | -- |This describes the contents of the current view and is separated from MyGUI, 78 | -- because we might want to have multiple views. 79 | data MyView = MkMyView { 80 | view :: !(TVar FMView) 81 | , cwd :: !(MVar Item) 82 | , rawModel :: !(TVar (ListStore Item)) 83 | , sortedModel :: !(TVar (TypedTreeModelSort Item)) 84 | , filteredModel :: !(TVar (TypedTreeModelFilter Item)) 85 | , inotify :: !(MVar INotify) 86 | , notebook :: !Notebook -- current notebook 87 | 88 | -- the first part of the tuple represents the "go back" 89 | -- the second part the "go forth" in the history 90 | , history :: !(MVar BrowsingHistory) 91 | 92 | -- sub-widgets 93 | , scroll :: !ScrolledWindow 94 | , viewBox :: !Box 95 | , backViewB :: !Button 96 | , upViewB :: !Button 97 | , forwardViewB :: !Button 98 | , homeViewB :: !Button 99 | , refreshViewB :: !Button 100 | , urlBar :: !Entry 101 | } 102 | 103 | 104 | data MenuBar = MkMenuBar { 105 | menubarFileQuit :: !ImageMenuItem 106 | , menubarHelpAbout :: !ImageMenuItem 107 | } 108 | 109 | data RightClickMenu = MkRightClickMenu { 110 | rcMenu :: !Menu 111 | , rcFileOpen :: !ImageMenuItem 112 | , rcFileExecute :: !ImageMenuItem 113 | , rcFileNewRegFile :: !ImageMenuItem 114 | , rcFileNewDir :: !ImageMenuItem 115 | , rcFileNewTab :: !ImageMenuItem 116 | , rcFileNewTerm :: !ImageMenuItem 117 | , rcFileCut :: !ImageMenuItem 118 | , rcFileCopy :: !ImageMenuItem 119 | , rcFileRename :: !ImageMenuItem 120 | , rcFilePaste :: !ImageMenuItem 121 | , rcFileDelete :: !ImageMenuItem 122 | , rcFileProperty :: !ImageMenuItem 123 | , rcFileIconView :: !ImageMenuItem 124 | , rcFileTreeView :: !ImageMenuItem 125 | } 126 | 127 | data FilePropertyGrid = MkFilePropertyGrid { 128 | fpropGrid :: !Grid 129 | , fpropFnEntry :: !Entry 130 | , fpropLocEntry :: !Entry 131 | , fpropTsEntry :: !Entry 132 | , fpropModEntry :: !Entry 133 | , fpropAcEntry :: !Entry 134 | , fpropFTEntry :: !Entry 135 | , fpropPermEntry :: !Entry 136 | , fpropLDEntry :: !Entry 137 | } 138 | 139 | 140 | -- |FM-wide settings. 141 | data FMSettings = MkFMSettings { 142 | showHidden :: !Bool 143 | , isLazy :: !Bool 144 | , iconSize :: !Int 145 | } 146 | 147 | data FMView = FMTreeView !TreeView 148 | | FMIconView !IconView 149 | 150 | type Item = File FileInfo 151 | 152 | 153 | 154 | fmViewToContainer :: FMView -> Container 155 | fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x 156 | fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x 157 | 158 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Dialogs.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# LANGUAGE CPP #-} 20 | {-# OPTIONS_HADDOCK ignore-exports #-} 21 | 22 | module HSFM.GUI.Gtk.Dialogs where 23 | 24 | 25 | import Codec.Binary.UTF8.String 26 | ( 27 | decodeString 28 | ) 29 | import Control.Exception 30 | ( 31 | catches 32 | , displayException 33 | , throwIO 34 | , IOException 35 | , Handler(..) 36 | ) 37 | import Control.Monad 38 | ( 39 | forM 40 | , when 41 | , void 42 | ) 43 | import Data.ByteString 44 | ( 45 | ByteString 46 | ) 47 | import qualified Data.ByteString as BS 48 | import Data.ByteString.UTF8 49 | ( 50 | fromString 51 | ) 52 | import Distribution.Package 53 | ( 54 | PackageIdentifier(..) 55 | , packageVersion 56 | , unPackageName 57 | ) 58 | #if MIN_VERSION_Cabal(2,0,0) 59 | import Distribution.Version 60 | ( 61 | showVersion 62 | ) 63 | #else 64 | import Data.Version 65 | ( 66 | showVersion 67 | ) 68 | #endif 69 | import Distribution.PackageDescription 70 | ( 71 | GenericPackageDescription(..) 72 | , PackageDescription(..) 73 | ) 74 | #if MIN_VERSION_Cabal(2,2,0) 75 | import Distribution.PackageDescription.Parsec 76 | #else 77 | import Distribution.PackageDescription.Parse 78 | #endif 79 | ( 80 | #if MIN_VERSION_Cabal(2,0,0) 81 | readGenericPackageDescription, 82 | #else 83 | readPackageDescription, 84 | #endif 85 | ) 86 | import Distribution.Verbosity 87 | ( 88 | silent 89 | ) 90 | import Graphics.UI.Gtk 91 | import qualified HPath as P 92 | import HPath.IO.Errors 93 | import HSFM.FileSystem.FileType 94 | import HSFM.FileSystem.UtilTypes 95 | import HSFM.GUI.Glib.GlibString() 96 | import HSFM.GUI.Gtk.Data 97 | import HSFM.GUI.Gtk.Errors 98 | import Paths_hsfm 99 | ( 100 | getDataFileName 101 | ) 102 | import System.Glib.UTFString 103 | ( 104 | GlibString 105 | ) 106 | import System.Posix.FilePath 107 | ( 108 | takeFileName 109 | ) 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | --------------------- 118 | --[ Dialog popups ]-- 119 | --------------------- 120 | 121 | 122 | -- |Pops up an error Dialog with the given String. 123 | showErrorDialog :: String -> IO () 124 | showErrorDialog str = do 125 | errorDialog <- messageDialogNew Nothing 126 | [DialogDestroyWithParent] 127 | MessageError 128 | ButtonsClose 129 | str 130 | _ <- dialogRun errorDialog 131 | widgetDestroy errorDialog 132 | 133 | 134 | -- |Asks the user for confirmation and returns True/False. 135 | showConfirmationDialog :: String -> IO Bool 136 | showConfirmationDialog str = do 137 | confirmDialog <- messageDialogNew Nothing 138 | [DialogDestroyWithParent] 139 | MessageQuestion 140 | ButtonsYesNo 141 | str 142 | rID <- dialogRun confirmDialog 143 | widgetDestroy confirmDialog 144 | case rID of 145 | ResponseYes -> return True 146 | ResponseNo -> return False 147 | _ -> return False 148 | 149 | 150 | fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode) 151 | fileCollisionDialog t = do 152 | chooserDialog <- messageDialogNew Nothing 153 | [DialogDestroyWithParent] 154 | MessageQuestion 155 | ButtonsNone 156 | (fromString "Target \"" `BS.append` 157 | t `BS.append` 158 | fromString "\" exists, how to proceed?") 159 | _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) 160 | _ <- dialogAddButton chooserDialog "Overwrite" (ResponseUser 1) 161 | _ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2) 162 | _ <- dialogAddButton chooserDialog "Skip" (ResponseUser 3) 163 | _ <- dialogAddButton chooserDialog "Rename" (ResponseUser 4) 164 | rID <- dialogRun chooserDialog 165 | widgetDestroy chooserDialog 166 | case rID of 167 | ResponseUser 0 -> return Nothing 168 | ResponseUser 1 -> return (Just Overwrite) 169 | ResponseUser 2 -> return (Just OverwriteAll) 170 | ResponseUser 3 -> return (Just Skip) 171 | ResponseUser 4 -> do 172 | mfn <- textInputDialog (fromString "Enter new name") (takeFileName t) 173 | forM mfn $ \fn -> do 174 | pfn <- P.parseRel (fromString fn) 175 | return $ Rename pfn 176 | _ -> throwIO UnknownDialogButton 177 | 178 | 179 | renameDialog :: ByteString -> IO (Maybe FCollisonMode) 180 | renameDialog t = do 181 | chooserDialog <- messageDialogNew Nothing 182 | [DialogDestroyWithParent] 183 | MessageQuestion 184 | ButtonsNone 185 | (fromString "Target \"" `BS.append` 186 | t `BS.append` 187 | fromString "\" exists, how to proceed?") 188 | _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) 189 | _ <- dialogAddButton chooserDialog "Skip" (ResponseUser 1) 190 | _ <- dialogAddButton chooserDialog "Rename" (ResponseUser 2) 191 | rID <- dialogRun chooserDialog 192 | widgetDestroy chooserDialog 193 | case rID of 194 | ResponseUser 0 -> return Nothing 195 | ResponseUser 1 -> return (Just Skip) 196 | ResponseUser 2 -> do 197 | mfn <- textInputDialog (fromString "Enter new name") (takeFileName t) 198 | forM mfn $ \fn -> do 199 | pfn <- P.parseRel (fromString fn) 200 | return $ Rename pfn 201 | _ -> throwIO UnknownDialogButton 202 | 203 | 204 | -- |Shows the about dialog from the help menu. 205 | showAboutDialog :: IO () 206 | showAboutDialog = do 207 | ad <- aboutDialogNew 208 | lstr <- Prelude.readFile =<< getDataFileName "LICENSE" 209 | hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png" 210 | pdesc <- fmap packageDescription 211 | #if MIN_VERSION_Cabal(2,0,0) 212 | (readGenericPackageDescription silent 213 | #else 214 | (readPackageDescription silent 215 | #endif 216 | =<< getDataFileName "hsfm.cabal") 217 | set ad 218 | [ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc 219 | , aboutDialogName := (unPackageName . pkgName . package) pdesc 220 | , aboutDialogVersion := (showVersion . packageVersion . package) pdesc 221 | , aboutDialogCopyright := copyright pdesc 222 | , aboutDialogComments := description pdesc 223 | , aboutDialogLicense := Just lstr 224 | , aboutDialogWebsite := homepage pdesc 225 | , aboutDialogAuthors := [author pdesc] 226 | , aboutDialogLogo := Just hsfmicon 227 | , aboutDialogWrapLicense := True 228 | ] 229 | _ <- dialogRun ad 230 | widgetDestroy ad 231 | 232 | 233 | -- |Carry out an IO action with a confirmation dialog. 234 | -- If the user presses "No", then do nothing. 235 | withConfirmationDialog :: String -> IO () -> IO () 236 | withConfirmationDialog str io = do 237 | run <- showConfirmationDialog str 238 | when run io 239 | 240 | 241 | -- |Execute the given IO action. If the action throws exceptions, 242 | -- visualize them via 'showErrorDialog'. 243 | withErrorDialog :: IO a -> IO () 244 | withErrorDialog io = 245 | catches (void io) 246 | [ Handler (\e -> showErrorDialog 247 | . decodeString 248 | . displayException 249 | $ (e :: IOException)) 250 | , Handler (\e -> showErrorDialog 251 | $ displayException (e :: HPathIOException)) 252 | ] 253 | 254 | 255 | -- |Asks the user which directory copy mode he wants via dialog popup 256 | -- and returns 'DirCopyMode'. 257 | textInputDialog :: (GlibString s1, GlibString s2) 258 | => s1 -- ^ window title 259 | -> s2 -- ^ initial text in input widget 260 | -> IO (Maybe String) 261 | textInputDialog title inittext = do 262 | chooserDialog <- messageDialogNew Nothing 263 | [DialogDestroyWithParent] 264 | MessageQuestion 265 | ButtonsNone 266 | title 267 | entry <- entryNew 268 | entrySetText entry inittext 269 | cbox <- dialogGetActionArea chooserDialog 270 | _ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0) 271 | _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1) 272 | boxPackStart (castToBox cbox) entry PackNatural 5 273 | widgetShowAll chooserDialog 274 | rID <- dialogRun chooserDialog 275 | ret <- case rID of 276 | -- TODO: make this more safe 277 | ResponseUser 0 -> Just <$> entryGetText entry 278 | ResponseUser 1 -> return Nothing 279 | _ -> throwIO UnknownDialogButton 280 | widgetDestroy chooserDialog 281 | return ret 282 | 283 | 284 | showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO () 285 | showFilePropertyDialog [item] mygui _ = do 286 | dialog <- messageDialogNew Nothing 287 | [DialogDestroyWithParent] 288 | MessageInfo 289 | ButtonsNone 290 | "File Properties" 291 | 292 | let fprop' = fprop mygui 293 | grid = fpropGrid fprop' 294 | 295 | entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel 296 | $ P.basename . path $ item) 297 | entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item) 298 | entrySetText (fpropTsEntry fprop') (show . fileSize $ fvar item) 299 | entrySetText (fpropModEntry fprop') (packModTime item) 300 | entrySetText (fpropAcEntry fprop') (packAccessTime item) 301 | entrySetText (fpropFTEntry fprop') (packFileType item) 302 | entrySetText (fpropPermEntry fprop') 303 | (tail $ packPermissions item) -- throw away the filetype part 304 | case packLinkDestination item of 305 | (Just dest) -> do 306 | widgetSetSensitive (fpropLDEntry fprop') True 307 | entrySetText (fpropLDEntry fprop') dest 308 | Nothing -> do 309 | widgetSetSensitive (fpropLDEntry fprop') False 310 | entrySetText (fpropLDEntry fprop') "( Not a symlink )" 311 | 312 | 313 | cbox <- dialogGetActionArea dialog 314 | _ <- dialogAddButton dialog "Ok" (ResponseUser 0) 315 | _ <- dialogAddButton dialog "Cancel" (ResponseUser 1) 316 | boxPackStart (castToBox cbox) grid PackNatural 5 317 | 318 | widgetShowAll dialog 319 | _ <- dialogRun dialog 320 | 321 | -- make sure our grid does not get destroyed 322 | containerRemove (castToBox cbox) grid 323 | 324 | widgetDestroy dialog 325 | 326 | return () 327 | showFilePropertyDialog _ _ _ = return () 328 | 329 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Errors.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | -- |Provides error handling for Gtk. 22 | module HSFM.GUI.Gtk.Errors where 23 | 24 | 25 | import Control.Exception 26 | import Data.Typeable 27 | 28 | 29 | 30 | data GtkException = UnknownDialogButton 31 | deriving (Show, Typeable) 32 | 33 | instance Exception GtkException 34 | 35 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Icons.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | -- |Module for Gtk icon handling. 22 | module HSFM.GUI.Gtk.Icons where 23 | 24 | 25 | import Data.Maybe 26 | ( 27 | fromJust 28 | ) 29 | import Graphics.UI.Gtk 30 | import Paths_hsfm 31 | ( 32 | getDataFileName 33 | ) 34 | 35 | 36 | -- |Icon type we use in our GUI. 37 | data GtkIcon = IFolder 38 | | SymL 39 | | IFile 40 | | IError 41 | 42 | 43 | -- |Gets an icon from the default icon theme and falls back to project-icons 44 | -- if not found. The requested icon size is not guaranteed. 45 | getIcon :: GtkIcon -- ^ icon we want 46 | -> IconTheme -- ^ which icon theme to get the icon from 47 | -> Int -- ^ requested icon size 48 | -> IO Pixbuf 49 | getIcon icon itheme isize = do 50 | let iname = iconToStr icon 51 | hasicon <- iconThemeHasIcon itheme iname 52 | case hasicon of 53 | True -> fromJust <$> iconThemeLoadIcon itheme iname isize 54 | IconLookupUseBuiltin 55 | False -> pixbufNewFromFile =<< getDataFileName 56 | ("data/Gtk/icons/" ++ iname ++ ".png") 57 | where 58 | iconToStr IFolder = "gtk-directory" 59 | iconToStr IFile = "gtk-file" 60 | iconToStr IError = "error" 61 | iconToStr SymL = "emblem-symbolic-link" 62 | 63 | 64 | getSymlinkIcon :: GtkIcon -> IconTheme -> Int -> IO Pixbuf 65 | getSymlinkIcon icon itheme isize = do 66 | pix <- pixbufCopy =<< getIcon icon itheme isize 67 | sympix <- getIcon SymL itheme isize 68 | 69 | pixbufScale sympix pix 0 0 12 12 0 0 0.5 0.5 InterpNearest 70 | 71 | return pix 72 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/MyGUI.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# LANGUAGE RecordWildCards #-} 20 | {-# OPTIONS_HADDOCK ignore-exports #-} 21 | 22 | module HSFM.GUI.Gtk.MyGUI where 23 | 24 | 25 | import Control.Concurrent.STM 26 | ( 27 | newTVarIO 28 | ) 29 | import Graphics.UI.Gtk 30 | import HSFM.FileSystem.UtilTypes 31 | import HSFM.GUI.Gtk.Data 32 | import Paths_hsfm 33 | ( 34 | getDataFileName 35 | ) 36 | 37 | 38 | 39 | 40 | ------------------------- 41 | --[ Main Window Setup ]-- 42 | ------------------------- 43 | 44 | 45 | -- |Set up the GUI. This only creates the permanent widgets. 46 | createMyGUI :: IO MyGUI 47 | createMyGUI = do 48 | let settings' = MkFMSettings False True 24 49 | settings <- newTVarIO settings' 50 | operationBuffer <- newTVarIO None 51 | 52 | builder <- builderNew 53 | builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" 54 | 55 | -- get the pre-defined gui widgets 56 | rootWin <- builderGetObject builder castToWindow 57 | "rootWin" 58 | menubarFileQuit <- builderGetObject builder castToImageMenuItem 59 | "menubarFileQuit" 60 | menubarHelpAbout <- builderGetObject builder castToImageMenuItem 61 | "menubarHelpAbout" 62 | statusBar <- builderGetObject builder castToStatusbar 63 | "statusBar" 64 | clearStatusBar <- builderGetObject builder castToButton 65 | "clearStatusBar" 66 | fpropGrid <- builderGetObject builder castToGrid 67 | "fpropGrid" 68 | fpropFnEntry <- builderGetObject builder castToEntry 69 | "fpropFnEntry" 70 | fpropLocEntry <- builderGetObject builder castToEntry 71 | "fpropLocEntry" 72 | fpropTsEntry <- builderGetObject builder castToEntry 73 | "fpropTsEntry" 74 | fpropModEntry <- builderGetObject builder castToEntry 75 | "fpropModEntry" 76 | fpropAcEntry <- builderGetObject builder castToEntry 77 | "fpropAcEntry" 78 | fpropFTEntry <- builderGetObject builder castToEntry 79 | "fpropFTEntry" 80 | fpropPermEntry <- builderGetObject builder castToEntry 81 | "fpropPermEntry" 82 | fpropLDEntry <- builderGetObject builder castToEntry 83 | "fpropLDEntry" 84 | notebook1 <- builderGetObject builder castToNotebook 85 | "notebook1" 86 | notebook2 <- builderGetObject builder castToNotebook 87 | "notebook2" 88 | leftNbIcon <- builderGetObject builder castToImage 89 | "leftNbIcon" 90 | rightNbIcon <- builderGetObject builder castToImage 91 | "rightNbIcon" 92 | leftNbBtn <- builderGetObject builder castToToggleButton 93 | "leftNbBtn" 94 | rightNbBtn <- builderGetObject builder castToToggleButton 95 | "rightNbBtn" 96 | 97 | 98 | -- this is required so that hotkeys work as expected, because 99 | -- we then can connect to signals from `viewBox` more reliably 100 | widgetSetCanFocus notebook1 False 101 | widgetSetCanFocus notebook2 False 102 | 103 | -- notebook toggle buttons 104 | buttonSetImage leftNbBtn leftNbIcon 105 | buttonSetImage rightNbBtn rightNbIcon 106 | widgetSetSensitive leftNbIcon False 107 | widgetSetSensitive rightNbIcon False 108 | toggleButtonSetActive leftNbBtn True 109 | toggleButtonSetActive rightNbBtn True 110 | 111 | -- construct the gui object 112 | let menubar = MkMenuBar {..} 113 | let fprop = MkFilePropertyGrid {..} 114 | let mygui = MkMyGUI {..} 115 | 116 | -- sets the default icon 117 | _ <- windowSetDefaultIconFromFile 118 | =<< getDataFileName "data/Gtk/icons/hsfm.png" 119 | 120 | return mygui 121 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/MyView.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# LANGUAGE RecordWildCards #-} 20 | 21 | 22 | module HSFM.GUI.Gtk.MyView where 23 | 24 | 25 | import Control.Concurrent.MVar 26 | ( 27 | newEmptyMVar 28 | , putMVar 29 | , tryTakeMVar 30 | ) 31 | import Control.Concurrent.STM 32 | ( 33 | newTVarIO 34 | , readTVarIO 35 | ) 36 | import Control.Monad 37 | ( 38 | unless 39 | , void 40 | , when 41 | ) 42 | import Control.Monad.IO.Class 43 | ( 44 | liftIO 45 | ) 46 | import Data.Foldable 47 | ( 48 | for_ 49 | ) 50 | import Data.Maybe 51 | ( 52 | catMaybes 53 | , fromJust 54 | ) 55 | import Data.String 56 | ( 57 | fromString 58 | ) 59 | import Graphics.UI.Gtk 60 | import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks) 61 | import qualified HPath as P 62 | import HSFM.FileSystem.FileType 63 | import HSFM.GUI.Glib.GlibString() 64 | import HSFM.GUI.Gtk.Data 65 | import HSFM.GUI.Gtk.Icons 66 | import HSFM.GUI.Gtk.Utils 67 | import HSFM.History 68 | import HSFM.Utils.IO 69 | import Paths_hsfm 70 | ( 71 | getDataFileName 72 | ) 73 | import Prelude hiding(readFile) 74 | import System.INotify 75 | ( 76 | addWatch 77 | , initINotify 78 | , killINotify 79 | , EventVariety(..) 80 | ) 81 | import System.IO.Error 82 | ( 83 | catchIOError 84 | , ioError 85 | , isUserError 86 | ) 87 | import System.Posix.FilePath 88 | ( 89 | hiddenFile 90 | ) 91 | 92 | 93 | 94 | -- |Creates a new tab with its own view and refreshes the view. 95 | newTab :: MyGUI -> Notebook -> IO FMView -> Item -> Int -> IO MyView 96 | newTab mygui nb iofmv item pos = do 97 | 98 | 99 | -- create eventbox with label 100 | label <- labelNewWithMnemonic 101 | (maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item) 102 | ebox <- eventBoxNew 103 | eventBoxSetVisibleWindow ebox False 104 | containerAdd ebox label 105 | widgetShowAll label 106 | 107 | myview <- createMyView mygui nb iofmv 108 | _ <- notebookInsertPageMenu (notebook myview) (viewBox myview) 109 | ebox ebox pos 110 | 111 | -- set initial history 112 | let historySize = 5 113 | putMVar (history myview) 114 | (BrowsingHistory [] (path item) [] historySize) 115 | 116 | notebookSetTabReorderable (notebook myview) (viewBox myview) True 117 | 118 | catchIOError (refreshView mygui myview item) $ \e -> do 119 | file <- pathToFile getFileInfo . fromJust . P.parseAbs . fromString 120 | $ "/" 121 | refreshView mygui myview file 122 | labelSetText label (fromString "/" :: String) 123 | unless (isUserError e) (ioError e) 124 | 125 | -- close callback 126 | _ <- ebox `on` buttonPressEvent $ do 127 | eb <- eventButton 128 | case eb of 129 | MiddleButton -> liftIO $ do 130 | n <- notebookGetNPages (notebook myview) 131 | when (n > 1) $ void $ destroyView myview 132 | return True 133 | _ -> return False 134 | 135 | return myview 136 | 137 | 138 | -- |Constructs the initial MyView object with a few dummy models. 139 | -- It also initializes the callbacks. 140 | createMyView :: MyGUI 141 | -> Notebook 142 | -> IO FMView 143 | -> IO MyView 144 | createMyView mygui nb iofmv = do 145 | inotify <- newEmptyMVar 146 | history <- newEmptyMVar 147 | 148 | builder <- builderNew 149 | builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" 150 | 151 | -- create dummy models, so we don't have to use MVar 152 | rawModel <- newTVarIO =<< listStoreNew [] 153 | filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x []) 154 | =<< readTVarIO rawModel 155 | sortedModel <- newTVarIO =<< treeModelSortNewWithModel 156 | =<< readTVarIO filteredModel 157 | cwd <- newEmptyMVar 158 | view' <- iofmv 159 | view <- newTVarIO view' 160 | 161 | urlBar <- builderGetObject builder castToEntry 162 | "urlBar" 163 | 164 | backViewB <- builderGetObject builder castToButton 165 | "backViewB" 166 | upViewB <- builderGetObject builder castToButton 167 | "upViewB" 168 | forwardViewB <- builderGetObject builder castToButton 169 | "forwardViewB" 170 | homeViewB <- builderGetObject builder castToButton 171 | "homeViewB" 172 | refreshViewB <- builderGetObject builder castToButton 173 | "refreshViewB" 174 | scroll <- builderGetObject builder castToScrolledWindow 175 | "mainScroll" 176 | viewBox <- builderGetObject builder castToBox 177 | "viewBox" 178 | 179 | let notebook = nb 180 | let myview = MkMyView {..} 181 | 182 | -- set the bindings 183 | setViewCallbacks mygui myview 184 | 185 | -- add the treeview to the scroll container 186 | let oview = fmViewToContainer view' 187 | containerAdd scroll oview 188 | 189 | widgetShowAll viewBox 190 | 191 | return myview 192 | 193 | 194 | -- |Switch the existing view in `MyView` with the one that the 195 | -- io action returns. 196 | switchView :: MyGUI -> MyView -> IO FMView -> IO () 197 | switchView mygui myview iofmv = do 198 | cwd <- getCurrentDir myview 199 | 200 | let nb = notebook myview 201 | 202 | oldpage <- destroyView myview 203 | 204 | -- create new view and tab page where the previous one was 205 | nview <- newTab mygui nb iofmv cwd oldpage 206 | 207 | page <- fromJust <$> notebookPageNum nb (viewBox nview) 208 | notebookSetCurrentPage nb page 209 | 210 | refreshView mygui nview cwd 211 | 212 | 213 | -- |Destroys the given view by disconnecting the watcher 214 | -- and destroying the active FMView container. 215 | -- 216 | -- Everything that needs to be done in order to forget about a 217 | -- view needs to be done here. 218 | -- 219 | -- Returns the page in the tab list this view corresponds to. 220 | destroyView :: MyView -> IO Int 221 | destroyView myview = do 222 | -- disconnect watcher 223 | mi <- tryTakeMVar (inotify myview) 224 | for_ mi $ \i -> killINotify i 225 | 226 | page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview) 227 | 228 | -- destroy old view and tab page 229 | view' <- readTVarIO $ view myview 230 | widgetDestroy (fmViewToContainer view') 231 | notebookRemovePage (notebook myview) page 232 | 233 | return page 234 | 235 | 236 | -- |Createss an IconView. 237 | createIconView :: IO FMView 238 | createIconView = do 239 | iconv <- iconViewNew 240 | iconViewSetSelectionMode iconv SelectionMultiple 241 | iconViewSetColumns iconv (-1) 242 | iconViewSetSpacing iconv 2 243 | iconViewSetMargin iconv 0 244 | {- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -} 245 | {- set iconv [ iconViewOrientation := OrientationHorizontal ] -} 246 | 247 | return $ FMIconView iconv 248 | 249 | 250 | -- |Creates a TreeView. 251 | createTreeView :: IO FMView 252 | createTreeView = do 253 | -- create the final view 254 | treeView <- treeViewNew 255 | -- set selection mode 256 | tvs <- treeViewGetSelection treeView 257 | treeSelectionSetMode tvs SelectionMultiple 258 | 259 | -- set drag and drop 260 | tl <- targetListNew 261 | atom <- atomNew ("HSFM" :: String) 262 | targetListAdd tl atom [TargetSameApp] 0 263 | treeViewEnableModelDragDest treeView tl [ActionCopy] 264 | treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy] 265 | 266 | -- create final tree model columns 267 | renderTxt <- cellRendererTextNew 268 | renderPix <- cellRendererPixbufNew 269 | let ct = cellText :: (CellRendererTextClass cr) => Attr cr String 270 | cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf 271 | 272 | -- filename column 273 | cF <- treeViewColumnNew 274 | treeViewColumnSetTitle cF ("Filename" :: String) 275 | treeViewColumnSetResizable cF True 276 | treeViewColumnSetClickable cF True 277 | treeViewColumnSetSortColumnId cF 1 278 | cellLayoutPackStart cF renderPix False 279 | cellLayoutPackStart cF renderTxt True 280 | _ <- treeViewAppendColumn treeView cF 281 | cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0 282 | cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1 283 | 284 | -- date column 285 | cMD <- treeViewColumnNew 286 | treeViewColumnSetTitle cMD ("Date" :: String) 287 | treeViewColumnSetResizable cMD True 288 | treeViewColumnSetClickable cMD True 289 | treeViewColumnSetSortColumnId cMD 2 290 | cellLayoutPackStart cMD renderTxt True 291 | _ <- treeViewAppendColumn treeView cMD 292 | cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2 293 | 294 | -- permissions column 295 | cP <- treeViewColumnNew 296 | treeViewColumnSetTitle cP ("Permission" :: String) 297 | treeViewColumnSetResizable cP True 298 | treeViewColumnSetClickable cP True 299 | treeViewColumnSetSortColumnId cP 3 300 | cellLayoutPackStart cP renderTxt True 301 | _ <- treeViewAppendColumn treeView cP 302 | cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3 303 | 304 | return $ FMTreeView treeView 305 | 306 | 307 | -- |Refreshes the View based on the given directory. 308 | -- 309 | -- Throws: 310 | -- 311 | -- - `userError` on inappropriate type 312 | refreshView :: MyGUI 313 | -> MyView 314 | -> Item 315 | -> IO () 316 | refreshView mygui myview SymLink { sdest = Just d@Dir{} } = 317 | refreshView mygui myview d 318 | refreshView mygui myview item@Dir{} = do 319 | newRawModel <- fileListStore item myview 320 | writeTVarIO (rawModel myview) newRawModel 321 | 322 | view' <- readTVarIO $ view myview 323 | 324 | _ <- tryTakeMVar (cwd myview) 325 | putMVar (cwd myview) item 326 | 327 | -- get selected items 328 | tps <- getSelectedTreePaths mygui myview 329 | trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps 330 | 331 | constructView mygui myview 332 | 333 | -- reselect selected items 334 | -- TODO: not implemented for icon view yet 335 | case view' of 336 | FMTreeView treeView -> do 337 | tvs <- treeViewGetSelection treeView 338 | ntps <- mapM treeRowReferenceGetPath trs 339 | mapM_ (treeSelectionSelectPath tvs) ntps 340 | _ -> return () 341 | refreshView _ _ _ = ioError $ userError "Inappropriate type!" 342 | 343 | 344 | -- |Constructs the visible View with the current underlying mutable models, 345 | -- which are retrieved from 'MyGUI'. 346 | -- 347 | -- This sort of merges the components mygui and myview and fires up 348 | -- the actual models. 349 | constructView :: MyGUI 350 | -> MyView 351 | -> IO () 352 | constructView mygui myview = do 353 | settings' <- readTVarIO $ settings mygui 354 | 355 | -- pix stuff 356 | iT <- iconThemeGetDefault 357 | folderPix <- getIcon IFolder iT (iconSize settings') 358 | folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings') 359 | filePix <- getIcon IFile iT (iconSize settings') 360 | fileSymPix <- getSymlinkIcon IFile iT (iconSize settings') 361 | errorPix <- getIcon IError iT (iconSize settings') 362 | let dirtreePix Dir{} = folderPix 363 | dirtreePix FileLike{} = filePix 364 | dirtreePix DirSym{} = folderSymPix 365 | dirtreePix FileLikeSym{} = fileSymPix 366 | dirtreePix BrokenSymlink{} = errorPix 367 | dirtreePix _ = errorPix 368 | 369 | 370 | view' <- readTVarIO $ view myview 371 | 372 | cdir <- getCurrentDir myview 373 | let cdirp = path cdir 374 | 375 | -- update urlBar 376 | entrySetText (urlBar myview) (P.fromAbs cdirp) 377 | 378 | rawModel' <- readTVarIO $ rawModel myview 379 | 380 | -- filtering 381 | filteredModel' <- treeModelFilterNew rawModel' [] 382 | writeTVarIO (filteredModel myview) filteredModel' 383 | treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do 384 | hidden <- showHidden <$> readTVarIO (settings mygui) 385 | item <- treeModelGetRow rawModel' iter >>= (P.basename . path) 386 | if hidden 387 | then return True 388 | else return . not . hiddenFile . P.fromRel $ item 389 | 390 | -- sorting 391 | sortedModel' <- treeModelSortNewWithModel filteredModel' 392 | writeTVarIO (sortedModel myview) sortedModel' 393 | treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do 394 | cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1 395 | cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2 396 | item1 <- treeModelGetRow rawModel' cIter1 397 | item2 <- treeModelGetRow rawModel' cIter2 398 | return $ compare item1 item2 399 | treeSortableSetSortColumnId sortedModel' 1 SortAscending 400 | 401 | -- set values 402 | treeModelSetColumn rawModel' (makeColumnIdPixbuf 0) 403 | dirtreePix 404 | treeModelSetColumn rawModel' (makeColumnIdString 1) 405 | (P.toFilePath . fromJust . P.basename . path) 406 | treeModelSetColumn rawModel' (makeColumnIdString 2) 407 | packModTime 408 | treeModelSetColumn rawModel' (makeColumnIdString 3) 409 | packPermissions 410 | 411 | -- update model of view 412 | case view' of 413 | FMTreeView treeView -> do 414 | treeViewSetModel treeView (Just sortedModel') 415 | treeViewSetRubberBanding treeView True 416 | FMIconView iconView -> do 417 | iconViewSetModel iconView (Just sortedModel') 418 | iconViewSetPixbufColumn iconView 419 | (makeColumnIdPixbuf 0 :: ColumnId item Pixbuf) 420 | iconViewSetTextColumn iconView 421 | (makeColumnIdString 1 :: ColumnId item String) 422 | 423 | -- add watcher 424 | mi <- tryTakeMVar (inotify myview) 425 | for_ mi $ \i -> killINotify i 426 | newi <- initINotify 427 | _ <- addWatch 428 | newi 429 | [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf] 430 | (P.fromAbs cdirp) 431 | (\_ -> postGUIAsync $ refreshView mygui myview cdir) 432 | putMVar (inotify myview) newi 433 | 434 | return () 435 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Plugins.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | 20 | {-# OPTIONS_HADDOCK ignore-exports #-} 21 | {-# OPTIONS_GHC -Wno-unused-imports #-} 22 | 23 | 24 | module HSFM.GUI.Gtk.Plugins where 25 | 26 | 27 | import Graphics.UI.Gtk 28 | import HPath 29 | import HSFM.FileSystem.FileType 30 | import HSFM.GUI.Gtk.Data 31 | import HSFM.GUI.Gtk.Settings 32 | import HSFM.GUI.Gtk.Utils 33 | import HSFM.Settings 34 | import Control.Monad 35 | ( 36 | forM 37 | , forM_ 38 | , void 39 | ) 40 | import System.Posix.Process.ByteString 41 | ( 42 | executeFile 43 | , forkProcess 44 | ) 45 | import Data.ByteString.UTF8 46 | ( 47 | fromString 48 | ) 49 | import qualified Data.ByteString as BS 50 | 51 | 52 | 53 | 54 | 55 | --------------- 56 | --[ Plugins ]-- 57 | --------------- 58 | 59 | 60 | 61 | 62 | ---- Global settings ---- 63 | 64 | 65 | 66 | -- |Where to start inserting plugins. 67 | insertPos :: Int 68 | insertPos = 4 69 | 70 | 71 | -- |A list of plugins to add to the right-click menu at position 72 | -- `insertPos`. 73 | -- 74 | -- The left part of the triple is a function that returns the menuitem. 75 | -- The middle part of the triple is a filter function that 76 | -- decides whether the item is shown. 77 | -- The right part of the triple is the callback, which is invoked 78 | -- when the menu item is clicked. 79 | -- 80 | -- Plugins are added in order of this list. 81 | myplugins :: [(IO MenuItem 82 | ,[Item] -> MyGUI -> MyView -> IO Bool 83 | ,[Item] -> MyGUI -> MyView -> IO ()) 84 | ] 85 | myplugins = [(diffItem, diffFilter, diffCallback) 86 | ] 87 | 88 | 89 | 90 | 91 | 92 | ---- The plugins ---- 93 | 94 | 95 | 96 | diffItem :: IO MenuItem 97 | diffItem = menuItemNewWithLabel "diff" 98 | 99 | diffFilter :: [Item] -> MyGUI -> MyView -> IO Bool 100 | diffFilter items _ _ 101 | | length items > 1 = return $ and $ fmap isFileC items 102 | | otherwise = return False 103 | 104 | diffCallback :: [Item] -> MyGUI -> MyView -> IO () 105 | diffCallback items _ _ = void $ 106 | forkProcess $ 107 | executeFile 108 | (fromString "meld") 109 | True 110 | ([fromString "--diff"] ++ fmap (fromAbs . path) items) 111 | Nothing 112 | 113 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Settings.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# LANGUAGE PatternSynonyms #-} 20 | 21 | 22 | module HSFM.GUI.Gtk.Settings where 23 | 24 | 25 | import Graphics.UI.Gtk 26 | 27 | 28 | 29 | 30 | -------------------- 31 | --[ GUI Settings ]-- 32 | -------------------- 33 | 34 | 35 | 36 | ---- Hotkey settings ---- 37 | 38 | 39 | pattern QuitModifier :: [Modifier] 40 | pattern QuitModifier <- [Control] 41 | 42 | pattern QuitKey :: String 43 | pattern QuitKey <- "q" 44 | 45 | 46 | pattern ShowHiddenModifier :: [Modifier] 47 | pattern ShowHiddenModifier <- [Control] 48 | 49 | pattern ShowHiddenKey :: String 50 | pattern ShowHiddenKey <- "h" 51 | 52 | 53 | pattern UpDirModifier :: [Modifier] 54 | pattern UpDirModifier <- [Alt] 55 | 56 | pattern UpDirKey :: String 57 | pattern UpDirKey <- "Up" 58 | 59 | 60 | pattern HistoryBackModifier :: [Modifier] 61 | pattern HistoryBackModifier <- [Alt] 62 | 63 | pattern HistoryBackKey :: String 64 | pattern HistoryBackKey <- "Left" 65 | 66 | 67 | pattern HistoryForwardModifier :: [Modifier] 68 | pattern HistoryForwardModifier <- [Alt] 69 | 70 | pattern HistoryForwardKey :: String 71 | pattern HistoryForwardKey <- "Right" 72 | 73 | 74 | pattern DeleteModifier :: [Modifier] 75 | pattern DeleteModifier <- [] 76 | 77 | pattern DeleteKey :: String 78 | pattern DeleteKey <- "Delete" 79 | 80 | 81 | pattern OpenModifier :: [Modifier] 82 | pattern OpenModifier <- [] 83 | 84 | pattern OpenKey :: String 85 | pattern OpenKey <- "Return" 86 | 87 | 88 | pattern CopyModifier :: [Modifier] 89 | pattern CopyModifier <- [Control] 90 | 91 | pattern CopyKey :: String 92 | pattern CopyKey <- "c" 93 | 94 | 95 | pattern MoveModifier :: [Modifier] 96 | pattern MoveModifier <- [Control] 97 | 98 | pattern MoveKey :: String 99 | pattern MoveKey <- "x" 100 | 101 | 102 | pattern PasteModifier :: [Modifier] 103 | pattern PasteModifier <- [Control] 104 | 105 | pattern PasteKey :: String 106 | pattern PasteKey <- "v" 107 | 108 | 109 | pattern NewTabModifier :: [Modifier] 110 | pattern NewTabModifier <- [Control] 111 | 112 | pattern NewTabKey :: String 113 | pattern NewTabKey <- "t" 114 | 115 | 116 | pattern CloseTabModifier :: [Modifier] 117 | pattern CloseTabModifier <- [Control] 118 | 119 | pattern CloseTabKey :: String 120 | pattern CloseTabKey <- "w" 121 | 122 | 123 | pattern OpenTerminalModifier :: [Modifier] 124 | pattern OpenTerminalModifier <- [] 125 | 126 | pattern OpenTerminalKey :: String 127 | pattern OpenTerminalKey <- "F4" 128 | 129 | -------------------------------------------------------------------------------- /src/HSFM/GUI/Gtk/Utils.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | module HSFM.GUI.Gtk.Utils where 22 | 23 | 24 | import Control.Concurrent.MVar 25 | ( 26 | readMVar 27 | ) 28 | import Control.Concurrent.STM 29 | ( 30 | readTVarIO 31 | ) 32 | import Data.Maybe 33 | ( 34 | catMaybes 35 | , fromJust 36 | ) 37 | import Data.Traversable 38 | ( 39 | forM 40 | ) 41 | import Graphics.UI.Gtk 42 | import HSFM.FileSystem.FileType 43 | import HSFM.GUI.Gtk.Data 44 | import Prelude hiding(getContents) 45 | 46 | 47 | 48 | ----------------- 49 | --[ Utilities ]-- 50 | ----------------- 51 | 52 | 53 | getSelectedTreePaths :: MyGUI -> MyView -> IO [TreePath] 54 | getSelectedTreePaths _ myview = do 55 | view' <- readTVarIO $ view myview 56 | case view' of 57 | FMTreeView treeView -> do 58 | tvs <- treeViewGetSelection treeView 59 | treeSelectionGetSelectedRows tvs 60 | FMIconView iconView -> 61 | iconViewGetSelectedItems iconView 62 | 63 | 64 | -- |Gets the currently selected item of the treeView, if any. 65 | getSelectedItems :: MyGUI 66 | -> MyView 67 | -> IO [Item] 68 | getSelectedItems mygui myview = do 69 | tps <- getSelectedTreePaths mygui myview 70 | catMaybes <$> mapM (rawPathToItem myview) tps 71 | 72 | 73 | -- |Carry out an action on the currently selected item. 74 | -- 75 | -- If there is no item selected, does nothing. 76 | withItems :: MyGUI 77 | -> MyView 78 | -> ( [Item] 79 | -> MyGUI 80 | -> MyView 81 | -> IO a) -- ^ action to carry out 82 | -> IO a 83 | withItems mygui myview io = do 84 | items <- getSelectedItems mygui myview 85 | io items mygui myview 86 | 87 | 88 | -- |Create the 'ListStore' of files/directories from the current directory. 89 | -- This is the function which maps the Data.DirTree data structures 90 | -- into the GTK+ data structures. 91 | fileListStore :: Item -- ^ current dir 92 | -> MyView 93 | -> IO (ListStore Item) 94 | fileListStore dt _ = do 95 | cs <- getContents getFileInfo dt 96 | listStoreNew cs 97 | 98 | 99 | -- |Currently unsafe. This is used to obtain any item, which will 100 | -- fail if there is none. 101 | getFirstItem :: MyView 102 | -> IO Item 103 | getFirstItem myview = do 104 | rawModel' <- readTVarIO $ rawModel myview 105 | iter <- fromJust <$> treeModelGetIterFirst rawModel' 106 | treeModelGetRow rawModel' iter 107 | 108 | 109 | -- |Reads the current directory from MyView. 110 | -- 111 | -- This reads the MVar and may block the main thread if it's 112 | -- empty. 113 | getCurrentDir :: MyView 114 | -> IO Item 115 | getCurrentDir myview = readMVar (cwd myview) 116 | 117 | 118 | -- |Push a message to the status bar. 119 | pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId) 120 | pushStatusBar mygui str = do 121 | let sb = statusBar mygui 122 | cid <- statusbarGetContextId sb "FM Status" 123 | mid <- statusbarPush sb cid str 124 | return (cid, mid) 125 | 126 | 127 | -- |Pop a message from the status bar. 128 | popStatusbar :: MyGUI -> IO () 129 | popStatusbar mygui = do 130 | let sb = statusBar mygui 131 | cid <- statusbarGetContextId sb "FM Status" 132 | statusbarPop sb cid 133 | 134 | 135 | -- |Turn a path on the rawModel into a path that we can 136 | -- use at the outermost model layer. 137 | rawPathToIter :: MyView -> TreePath -> IO (Maybe TreeIter) 138 | rawPathToIter myview tp = do 139 | fmodel <- readTVarIO (filteredModel myview) 140 | smodel <- readTVarIO (sortedModel myview) 141 | msiter <- treeModelGetIter smodel tp 142 | forM msiter $ \siter -> do 143 | cIter <- treeModelSortConvertIterToChildIter smodel siter 144 | treeModelFilterConvertIterToChildIter fmodel cIter 145 | 146 | 147 | -- |Turn a path on the rawModel into the corresponding item 148 | -- that we can use at the outermost model layer. 149 | rawPathToItem :: MyView -> TreePath -> IO (Maybe Item) 150 | rawPathToItem myview tp = do 151 | rawModel' <- readTVarIO $ rawModel myview 152 | miter <- rawPathToIter myview tp 153 | forM miter $ \iter -> treeModelGetRow rawModel' iter 154 | 155 | -------------------------------------------------------------------------------- /src/HSFM/History.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | module HSFM.History where 22 | 23 | 24 | import HPath 25 | ( 26 | Abs 27 | , Path 28 | ) 29 | 30 | 31 | 32 | -- |Browsing history. For `forwardHistory` and `backwardsHistory` 33 | -- the first item is the most recent one. 34 | data BrowsingHistory = BrowsingHistory { 35 | backwardsHistory :: [Path Abs] 36 | , currentDir :: Path Abs 37 | , forwardHistory :: [Path Abs] 38 | , maxSize :: Int 39 | } 40 | 41 | 42 | -- |This is meant to be called after e.g. a new path is entered 43 | -- (not navigated to via the history) and the history needs updating. 44 | historyNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory 45 | historyNewPath p (BrowsingHistory b cd _ s) = 46 | BrowsingHistory (take s $ cd:b) p [] s 47 | 48 | 49 | -- |Go back one step in the history. 50 | historyBack :: BrowsingHistory -> BrowsingHistory 51 | historyBack bh@(BrowsingHistory [] _ _ _) = bh 52 | historyBack (BrowsingHistory (b:bs) cd fs s) = 53 | BrowsingHistory bs b (take s $ cd:fs) s 54 | 55 | 56 | -- |Go forward one step in the history. 57 | historyForward :: BrowsingHistory -> BrowsingHistory 58 | historyForward bh@(BrowsingHistory _ _ [] _) = bh 59 | historyForward (BrowsingHistory bs cd (f:fs) s) = 60 | BrowsingHistory (take s $ cd:bs) f fs s 61 | 62 | -------------------------------------------------------------------------------- /src/HSFM/Settings.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | 22 | module HSFM.Settings where 23 | 24 | 25 | import Data.ByteString 26 | ( 27 | ByteString 28 | ) 29 | import qualified Data.ByteString.UTF8 as BU 30 | import Data.Maybe 31 | import System.Posix.Env.ByteString 32 | import System.Posix.Process.ByteString 33 | 34 | 35 | 36 | ----------------------- 37 | --[ Common Settings ]-- 38 | ----------------------- 39 | 40 | 41 | 42 | 43 | ---- Command settings ---- 44 | 45 | 46 | 47 | -- |The terminal command. This should call `executeFile` in the end 48 | -- with the appropriate arguments. 49 | terminalCommand :: ByteString -- ^ current directory of the FM 50 | -> IO a 51 | terminalCommand cwd = 52 | executeFile -- executes the given command 53 | (BU.fromString "sakura") -- the terminal command 54 | True -- whether to search PATH 55 | [BU.fromString "-d", cwd] -- arguments for the command 56 | Nothing -- optional custom environment: `Just [(String, String)]` 57 | 58 | 59 | -- |The home directory. If you want to set it explicitly, you might 60 | -- want to do: 61 | -- 62 | -- @ 63 | -- home = return "\/home\/wurst" 64 | -- @ 65 | home :: IO ByteString 66 | home = fromMaybe <$> return (BU.fromString "/") <*> getEnv (BU.fromString "HOME") 67 | 68 | -------------------------------------------------------------------------------- /src/HSFM/Utils/IO.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | {-# OPTIONS_HADDOCK ignore-exports #-} 20 | 21 | 22 | -- |Random and general IO utilities. 23 | module HSFM.Utils.IO where 24 | 25 | 26 | import Control.Concurrent.STM 27 | ( 28 | atomically 29 | ) 30 | import Control.Concurrent.STM.TVar 31 | ( 32 | writeTVar 33 | , modifyTVar 34 | , TVar 35 | ) 36 | 37 | 38 | -- |Atomically write a TVar. 39 | writeTVarIO :: TVar a -> a -> IO () 40 | writeTVarIO tvar val = atomically $ writeTVar tvar val 41 | 42 | 43 | -- |Atomically modify a TVar. 44 | modifyTVarIO :: TVar a -> (a -> a) -> IO () 45 | modifyTVarIO tvar f = atomically $ modifyTVar tvar f 46 | 47 | -------------------------------------------------------------------------------- /src/HSFM/Utils/MyPrelude.hs: -------------------------------------------------------------------------------- 1 | {-- 2 | HSFM, a filemanager written in Haskell. 3 | Copyright (C) 2016 Julian Ospald 4 | 5 | This program is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU General Public License 7 | version 2 as published by the Free Software Foundation. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | --} 18 | 19 | module HSFM.Utils.MyPrelude where 20 | 21 | 22 | import Data.List 23 | 24 | 25 | 26 | -- |Turns any list into a list of the same length with the values 27 | -- being the indices. 28 | -- E.g.: "abdasd" -> [0,1,2,3,4,5] 29 | listIndices :: [a] -> [Int] 30 | listIndices = findIndices (const True) 31 | 32 | 33 | -------------------------------------------------------------------------------- /update-gh-pages.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | SOURCE_BRANCH="master" 4 | TARGET_BRANCH="gh-pages" 5 | REPO="https://${GH_TOKEN}@github.com/hasufell/hsfm" 6 | DOC_LOCATION="/dist/doc/html/hsfm/hsfm-gtk" 7 | 8 | 9 | # Pull requests and commits to other branches shouldn't try to deploy, 10 | # just build to verify 11 | if [ "$TRAVIS_PULL_REQUEST" != "false" -o "$TRAVIS_BRANCH" != "$SOURCE_BRANCH" ]; then 12 | echo "Skipping docs deploy." 13 | exit 0 14 | fi 15 | 16 | 17 | cd "$HOME" 18 | git config --global user.email "travis@travis-ci.org" 19 | git config --global user.name "travis-ci" 20 | git clone --branch=${TARGET_BRANCH} ${REPO} ${TARGET_BRANCH} || exit 1 21 | 22 | # docs 23 | cd ${TARGET_BRANCH} || exit 1 24 | echo "Removing old docs." 25 | rm -rf * 26 | echo "Adding new docs." 27 | cp -rf "${TRAVIS_BUILD_DIR}${DOC_LOCATION}"/* . || exit 1 28 | 29 | # If there are no changes to the compiled out (e.g. this is a README update) 30 | # then just bail. 31 | if [ -z "`git diff --exit-code`" ]; then 32 | echo "No changes to the output on this push; exiting." 33 | exit 0 34 | fi 35 | 36 | git add -- . 37 | 38 | if [[ -e ./index.html ]] ; then 39 | echo "Commiting docs." 40 | git commit -m "Lastest docs updated 41 | 42 | travis build: $TRAVIS_BUILD_NUMBER 43 | commit: $TRAVIS_COMMIT 44 | auto-pushed to gh-pages" 45 | 46 | git push origin $TARGET_BRANCH 47 | echo "Published docs to gh-pages." 48 | else 49 | echo "Error: docs are empty." 50 | exit 1 51 | fi 52 | 53 | -------------------------------------------------------------------------------- /update-index-state.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -eu 4 | 5 | status_message() { 6 | printf "\\033[0;32m%s\\033[0m\\n" "$1" 7 | } 8 | 9 | error_message() { 10 | printf "\\033[0;31m%s\\033[0m\\n" "$1" 11 | } 12 | 13 | SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )" 14 | CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache" 15 | 16 | if [ ! -f "${CACHE_LOCATION}" ] ; then 17 | error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?" 18 | exit 1 19 | fi 20 | 21 | if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then 22 | error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update." 23 | exit 3 24 | fi 25 | 26 | cabal v2-update 27 | 28 | arch=$(getconf LONG_BIT) 29 | 30 | case "${arch}" in 31 | 32) 32 | byte_size=4 33 | magic_word="CABA1002" 34 | ;; 35 | 64) 36 | byte_size=8 37 | magic_word="00000000CABA1002" 38 | ;; 39 | *) 40 | error_message "Unknown architecture (long bit): ${arch}" 41 | exit 2 42 | ;; 43 | esac 44 | 45 | # This is the logic to parse the binary format of 01-index.cache. 46 | # The first word is a magic 'caba1002', the second one is the timestamp in unix epoch. 47 | # Better than copying the cabal-install source code. 48 | if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then 49 | error_message "Magic word does not match!" 50 | exit 4 51 | fi 52 | cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc) 53 | 54 | # If we got junk from the binary file, this should fail. 55 | cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ") 56 | 57 | 58 | status_message "Updating index state in ${SCRIPTPATH}/cabal.project" 59 | 60 | if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then 61 | awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp" 62 | mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project" 63 | else 64 | printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project" 65 | fi 66 | 67 | --------------------------------------------------------------------------------