hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

Compare commits

base: hasufell:travis
Branches Tags
hasufell:master hasufell:gh-pages hasufell:travis hasufell:development hasufell:bookmarks hasufell:docfix hasufell:develop
..
compare: hasufell:develop
Branches Tags
hasufell:master hasufell:gh-pages hasufell:travis hasufell:development hasufell:bookmarks hasufell:docfix hasufell:develop

2 Commits
travis ... develop

Author SHA1 Message Date
hasufell
3e0ef6be70 LIB: add TODO 2015-12-27 05:31:27 +01:00
hasufell
af6516a454 LIB: rm unneded import 2015-12-27 05:31:19 +01:00
32 changed files with 2849 additions and 3622 deletions
Expand all files Collapse all files

2
.gitignore vendored
View File

@@ -5,5 +5,3 @@ cabal.sandbox.config
*.hp *.hp
*.prof *.prof
*.old *.old
.liquid/
3rdparty/hpath

55
.travis.yml
View File

@@ -1,55 +0,0 @@
# See https://github.com/hvr/multi-ghc-travis for more information
language: c
sudo: required
dist: trusty
matrix:
include:
- env: CABALVER=1.24 GHCVER=7.10.2
addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.2,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=8.0.1
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}}
- env: CABALVER=head GHCVER=head
addons: {apt: {packages: [cabal-install-head,ghc-head,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}}
allow_failures:
- env: CABALVER=head GHCVER=head
before_install:
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
install:
- cabal --version
- travis_retry cabal update
- cabal sandbox init
- cabal install alex happy
- export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
- cabal install gtk2hs-buildtools
- cabal install --only-dependencies --enable-tests -j
script:
- cabal configure --enable-tests -v2
- cabal build
- cabal test
- cabal check
- cabal sdist
# check that the generated source-distribution can be built & installed
- export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
cd dist/;
cabal sandbox init;
if [ -f "$SRC_TGZ" ]; then
cabal install alex happy;
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH";
cabal install gtk2hs-buildtools;
cabal install "$SRC_TGZ" --enable-tests;
else
echo "expected '$SRC_TGZ' not found";
exit 1;
fi
notifications:
email:
- hasufell@posteo.de

1
HACKING.md
View File

@@ -1 +0,0 @@
hacking/HACKING.md

29
HACKING.md Normal file
View File

@@ -0,0 +1,29 @@
HACKING
=======
Coding style
------------
- match the sorroundings
- no overcomplicated pointfree style
- normal indenting 2 whitespaces
- just make things pretty and readable
Documentation
-------------
__Everything__ must be documented. :)
Hacking Guide
-------------
The main data structure is in [DirTree.hs](src/Data/DirTree.hs), which
should be seen as a library. This is then mapped into the Gtk+ GUI at
[Gtk.hs](src/GUI/Gtk.hs) and [Utils.hs](src/GUI/Gtk/Utils.hs).
File operations (like copy, delete etc) are defined at
[File.hs](src/IO/File.hs).
Note that the main data structures are still a bit in flux. Join
[the discussion](https://github.com/hasufell/hsfm/issues/12) on how to
improve them.

12
README.md
View File

@@ -1,7 +1,7 @@
HSFM HSFM
==== ====
[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](http://travis-ci.org/hasufell/hsfm) __NOTE: This project is in a highly experimental state! Don't complain if it deletes your whole home directory. You should use a chroot, docker environment or similar for testing.__
A Gtk+:3 filemanager written in Haskell. A Gtk+:3 filemanager written in Haskell.
@@ -12,19 +12,11 @@ Design goals:
- type safety, runtime safety, strictness - type safety, runtime safety, strictness
- simple add-on interface - simple add-on interface
Screenshots
-----------
![hsfm](https://cloud.githubusercontent.com/assets/1241845/14768900/06efd43c-0a4d-11e6-939e-6b067bdb47ce.png "hsfm-gtk")
Installation Installation
------------ ------------
``` ```
cabal sandbox init
cabal install alex happy
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
cabal install gtk2hs-buildtools
cabal install cabal install
``` ```
@@ -32,4 +24,4 @@ cabal install
Contributing Contributing
------------ ------------
See [HACKING.md](hacking/HACKING.md). See [HACKING.md](HACKING.md).

762
data/Gtk/builder.xml
View File

@@ -1,465 +1,12 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<!-- Generated with glade 3.18.3 --> <!-- Generated with glade 3.19.0 -->
<interface> <interface>
<requires lib="gtk+" version="3.16"/> <requires lib="gtk+" version="3.16"/>
<object class="GtkGrid" id="fpropGrid">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="row_spacing">2</property>
<property name="column_spacing">2</property>
<property name="row_homogeneous">True</property>
<child>
<object class="GtkLabel" id="label1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">File Name:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">0</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropFnEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">0</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Location:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">1</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Total Size:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">2</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropLocEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">1</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropTsEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">2</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label5">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Accessed:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">7</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label4">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Modified:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">6</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropModEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">6</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropAcEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">7</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label6">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">File Type:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">3</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropFTEntry">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">3</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropPermEntry">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">4</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label7">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Link Destination:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">5</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label8">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Permissions:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">4</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropLDEntry">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">5</property>
</packing>
</child>
</object>
<object class="GtkImage" id="image1"> <object class="GtkImage" id="image1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="stock">gtk-edit</property> <property name="stock">gtk-edit</property>
</object> </object>
<object class="GtkImage" id="image2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-open</property>
</object>
<object class="GtkImage" id="image3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-cancel</property>
</object>
<object class="GtkApplicationWindow" id="rootWin">
<property name="can_focus">False</property>
<child>
<object class="GtkBox" id="box1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="orientation">vertical</property>
<child>
<object class="GtkMenuBar" id="menubar">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkMenuItem" id="menubarFile">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">_File</property>
<property name="use_underline">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem1">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarFileQuit">
<property name="label">gtk-quit</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
</child>
</object>
</child>
<child>
<object class="GtkMenuItem" id="menubarView">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">View</property>
<child type="submenu">
<object class="GtkMenu" id="menu5">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
</object>
</child>
<child>
<object class="GtkMenuItem" id="menubarHelp">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">_Help</property>
<property name="use_underline">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarHelpAbout">
<property name="label">gtk-about</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
</child>
</object>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkNotebook" id="notebook">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="scrollable">True</property>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkBox" id="box3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkStatusbar" id="statusBar">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="margin_left">10</property>
<property name="margin_right">10</property>
<property name="margin_start">10</property>
<property name="margin_end">10</property>
<property name="margin_top">6</property>
<property name="margin_bottom">6</property>
<property name="orientation">vertical</property>
<property name="spacing">2</property>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkButton" id="clearStatusBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">5</property>
<property name="margin_bottom">5</property>
<property name="image">image3</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">3</property>
</packing>
</child>
</object>
</child>
</object>
<object class="GtkImage" id="image4">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-in</property>
</object>
<object class="GtkImage" id="image5">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-out</property>
</object>
<object class="GtkImage" id="image6">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-directory</property>
</object>
<object class="GtkImage" id="image7">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-fit</property>
</object>
<object class="GtkMenu" id="rcMenu"> <object class="GtkMenu" id="rcMenu">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
@@ -488,30 +35,6 @@
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="use_underline">True</property> <property name="use_underline">True</property>
<property name="use_stock">True</property> <property name="use_stock">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu6">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="rcFileNewRegFile">
<property name="label">gtk-file</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNewDir">
<property name="label" translatable="yes">directory</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image6</property>
<property name="use_stock">False</property>
</object>
</child>
</object>
</child>
</object> </object>
</child> </child>
<child> <child>
@@ -565,142 +88,251 @@
<property name="use_stock">True</property> <property name="use_stock">True</property>
</object> </object>
</child> </child>
</object>
<object class="GtkImage" id="image2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-edit</property>
</object>
<object class="GtkApplicationWindow" id="rootWin">
<property name="can_focus">False</property>
<child> <child>
<object class="GtkImageMenuItem" id="rcFileProperty"> <object class="GtkBox" id="box1">
<property name="label">gtk-properties</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="use_underline">True</property> <property name="orientation">vertical</property>
<property name="use_stock">True</property> <child>
</object> <object class="GtkMenuBar" id="menubar">
</child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem3">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileView">
<property name="label">View</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image7</property>
<property name="use_stock">False</property>
<child type="submenu">
<object class="GtkMenu" id="menu2">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkImageMenuItem" id="rcFileIconView"> <object class="GtkMenuItem" id="menubarFile">
<property name="label">icon view</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="image">image4</property> <property name="label" translatable="yes">_File</property>
<property name="use_stock">False</property> <property name="use_underline">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarFileOpen">
<property name="label">gtk-open</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarFileExecute">
<property name="label">gtk-execute</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarFileNew">
<property name="label">gtk-new</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem1">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarFileQuit">
<property name="label">gtk-quit</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
</child>
</object> </object>
</child> </child>
<child> <child>
<object class="GtkImageMenuItem" id="rcFileTreeView"> <object class="GtkMenuItem" id="menubarEdit">
<property name="label" translatable="yes">tree view</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="image">image5</property> <property name="label" translatable="yes">_Edit</property>
<property name="use_stock">False</property> <property name="use_underline">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarEditCut">
<property name="label">gtk-cut</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditCopy">
<property name="label">gtk-copy</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditRename">
<property name="label">Move</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image2</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditPaste">
<property name="label">gtk-paste</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditDelete">
<property name="label">gtk-delete</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
</child>
</object>
</child>
<child>
<object class="GtkMenuItem" id="menubarView">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">_View</property>
<property name="use_underline">True</property>
</object>
</child>
<child>
<object class="GtkMenuItem" id="menubarHelp">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">_Help</property>
<property name="use_underline">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarHelpAbout">
<property name="label">gtk-about</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
</child>
</object> </object>
</child> </child>
</object> </object>
</child>
</object>
</child>
</object>
<object class="GtkBox" id="viewBox">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="orientation">vertical</property>
<child>
<object class="GtkBox" id="box2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkEntry" id="urlBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
</object>
<packing> <packing>
<property name="expand">True</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">0</property> <property name="position">0</property>
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="upViewB"> <object class="GtkBox" id="box2">
<property name="label">gtk-go-up</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">False</property>
<property name="receives_default">True</property> <child>
<property name="use_stock">True</property> <object class="GtkEntry" id="urlBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkButton" id="refreshView">
<property name="label">gtk-refresh</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">5</property>
<property name="position">1</property>
</packing>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="padding">2</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="homeViewB"> <object class="GtkScrolledWindow" id="mainScroll">
<property name="label">gtk-home</property> <property name="width_request">300</property>
<property name="height_request">500</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="shadow_type">in</property>
<property name="use_stock">True</property> <child>
<placeholder/>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">2</property> <property name="position">2</property>
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="refreshViewB"> <object class="GtkStatusbar" id="statusBar">
<property name="label">gtk-refresh</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">False</property>
<property name="receives_default">True</property> <property name="margin_left">10</property>
<property name="use_stock">True</property> <property name="margin_right">10</property>
<property name="margin_start">10</property>
<property name="margin_end">10</property>
<property name="margin_top">6</property>
<property name="margin_bottom">6</property>
<property name="orientation">vertical</property>
<property name="spacing">2</property>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="padding">2</property>
<property name="position">3</property> <property name="position">3</property>
</packing> </packing>
</child> </child>
</object> </object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkScrolledWindow" id="mainScroll">
<property name="width_request">300</property>
<property name="height_request">500</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="shadow_type">in</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child> </child>
</object> </object>
</interface> </interface>

105
hacking/HACKING.md
View File

@@ -1,105 +0,0 @@
# HACKING
Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
if you don't know yet what you want to hack on.
## Coding style
- match the sorroundings
- no overcomplicated pointfree style
- normal indenting 2 whitespaces
- just make things pretty and readable
- you can use the provided [hsimport.hs](hsimport.hs)
## Documentation
__Everything__ must be documented. :)
Don't assume people know what you mean. Type signatures are not sufficient
documentation.
## Hacking Overview
Only a GTK GUI is currently implemented, the entry point being
[HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down
to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in
[HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs), which is sort of
a global object for the whole window. Inside this object are
theoretically multiple [MyView objects](./../src/HSFM/GUI/Gtk/Data.hs#L101)
allowed which represent the actual view on the filesystem and related
widgets, which are constructed in
[HSFM.GUI.Gtk.MyView](./../src/HSFM/GUI/Gtk/MyView.hs). Both MyGUI and MyView
are more or less accessible throughout the whole GTK callstack, expclicitly
passed as parameters.
For adding new GTK widgets with functionality you mostly have to touch the
following files:
* [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
* [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
* [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
* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
## Concepts
### Path safety
Paths are usually represented in haskell libraries as `type FilePath = String`.
This is bad, because of a number of reasons:
* encoding issues, since the low-level representation of filepaths is in fact an array of C chars
* weak typing... we could pass arbitrary invalid/malicious filepaths or other random strings
* no information about any property at type level (e.g. is it an absolute path?)
* no filepath constructors that do sanity checks and proper parsing
* no guarantee whether the filepath is normalised or not or even valid
Because of that, the solution is:
* use `ByteString` under the hood
* wrap it inside `Path t` where `t` can be either `Abs` (for absolute), `Rel` (for relative) or `Fn` (for filename)
* construct filepaths via smart constructors only that reject certain paths (like `.` or `..`) and normalise the path
This leads to the following benefits:
* we have guarantees about whether a path is absolute or not, which is important for runtime safety in general, predictable behavior and thread safety
* we don't mess with the filepath representation we get from low-level posix functions, so encoding issues are pretty much out
* we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
* filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
The [hpath](https://hackage.haskell.org/package/hpath) library does exactly that for us.
The only problem with this approach is that most libraries are still String
based. Some provide dedicated `Foo.ByteString` modules though, but it
might be necessary to fork libraries.
We also need to keep track of the [Abstract FilePath proposal](https://ghc.haskell.org/trac/ghc/wiki/Proposal/AbstractFilePath).
Almost all paths in HSFM are only allowed to be absolute (`Path Abs`), unless
they are filenames (`Path Fn`) and processed for GUI purposes. This is as
already mentioned for the purpose of runtime safety, predictability and
thread safety.
### File IO safety
This is a pretty difficult problem. One thing to ensure safety on IO level
is simply the strong haskell type system, since we push everything
into our `File a` type and can then pattern match easily against the different
types of files.
The only problem with this approach is that we are examining a file at point
`a` in time, safe the information and then use that information further down
the call stack at point `b` in time, when the file information in memory
could already be out of date. There are two approaches to make this less
sucky:
* use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
* 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
In addition, we don't use the `directory` package, which is dangerous
and broken. Instead, we use the [HPath.IO](https://hackage.haskell.org/package/hpath/docs/HPath-IO.html).
### Exception handling
Exceptions are good. We don't want to wrap everything in Maybe/Either types
unless we want to handle failure immediately. Otherwise we need to make
sure that at least at some point IOExceptions are caught and visualized
to the user. This is often done via e.g. `withErrorDialog` which catches
`IOException` and [HPathIOException](https://hackage.haskell.org/package/hpath/docs/HPath-IO-Errors.html#t:HPathIOException).
It's also important to clean up stuff like filedescriptors via
functions like `bracket` directly in our low-level code in case
something goes wrong.

53
hacking/hsimport.hs
View File

@@ -1,53 +0,0 @@
import Data.List
import qualified Language.Haskell.Exts as HS
import HsImport
main :: IO ()
main = hsimport $ defaultConfig { prettyPrint = prettyPrint
, findImportPos = findImportPos }
where
prettyPrint :: HS.ImportDecl -> String
prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
"import " ++ (ifStr qual "qualified ") ++
(maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++
getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
specprint mspec
specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
specprint Nothing = ""
specprint (Just (False, xs))
= "\n (\n" ++ printImportSpecs xs ++ " )"
specprint (Just (True, xs))
= "\n hiding (\n" ++ printImportSpecs xs ++ " )"
printImportSpecs :: [HS.ImportSpec] -> String
printImportSpecs ins
= let (x:xs) = sort ins
in " " ++ printSpec x ++ "\n" ++ go xs
where
go [] = ""
go [x'] = " , " ++ printSpec x' ++ "\n"
go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs'
printSpec :: HS.ImportSpec -> String
printSpec = HS.prettyPrint
findImportPos :: HS.ImportDecl -> [HS.ImportDecl] -> Maybe ImportPos
findImportPos _ [] = Nothing
findImportPos newImport currentImports = Just findPos
where
lastPos = After . last $ currentImports
findPos = let xs = takeWhile (\x -> (getMN $ HS.importModule x)
<
(getMN $ HS.importModule newImport)
)
. sort
$ currentImports
in if null xs then lastPos else After . last $ xs
ifStr :: Bool -> String -> String
ifStr True str = str
ifStr False _ = ""
getMN :: HS.ModuleName -> String
getMN (HS.ModuleName name) = name

122
hsfm.cabal
View File

@@ -6,87 +6,41 @@ license: GPL-2
license-file: LICENSE license-file: LICENSE
author: Julian Ospald author: Julian Ospald
maintainer: hasufell@hasufell.de maintainer: hasufell@hasufell.de
copyright: Copyright: (c) 2016 Julian Ospald copyright: Copyright: (c) 2015 Julian Ospald
homepage: https://github.com/hasufell/hsfm homepage: https://github.com/hasufell/hsfm
category: Desktop category: Desktop
build-type: Simple build-type: Simple
cabal-version: >=1.24 cabal-version: >=1.10
data-files: data-files: data/Gtk/builder.xml
LICENSE
data/Gtk/builder.xml
data/Gtk/icons/error.png data/Gtk/icons/error.png
data/Gtk/icons/gtk-directory.png data/Gtk/icons/gtk-directory.png
data/Gtk/icons/gtk-file.png data/Gtk/icons/gtk-file.png
data/Gtk/icons/hsfm.png data/Gtk/icons/hsfm.png
hsfm.cabal LICENSE
library library
exposed-modules: exposed-modules: Data.DirTree
HSFM.FileSystem.FileType IO.Utils
HSFM.FileSystem.UtilTypes IO.File
HSFM.Utils.IO IO.Error
HSFM.Utils.MyPrelude MyPrelude
build-depends: build-depends: base >= 4.7,
base >= 4.8 && < 5,
bytestring,
data-default, data-default,
bifunctors >= 5,
containers,
directory >= 1.1.0.0 && < 1.2.3.0,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
hinotify-bytestring, hinotify,
hpath >= 0.7.1, mtl >= 2.2,
safe,
stm,
time >= 1.4.2,
unix,
utf8-string
hs-source-dirs: src
default-language: Haskell2010
Default-Extensions: RecordWildCards
PatternSynonyms
FlexibleInstances
ViewPatterns
ghc-options:
-Wall
executable hsfm-gtk
main-is: HSFM/GUI/Gtk.hs
other-modules:
HSFM.GUI.Glib.GlibString
HSFM.GUI.Gtk.Callbacks
HSFM.GUI.Gtk.Callbacks.Utils
HSFM.GUI.Gtk.Data
HSFM.GUI.Gtk.Dialogs
HSFM.GUI.Gtk.Errors
HSFM.GUI.Gtk.Icons
HSFM.GUI.Gtk.MyGUI
HSFM.GUI.Gtk.MyView
HSFM.GUI.Gtk.Utils
HSFM.Utils.MyPrelude
build-depends:
Cabal >= 1.24.0.0,
base >= 4.8 && < 5,
bytestring,
data-default,
filepath >= 1.3.0.0,
glib >= 0.13,
gtk3 >= 0.14.1,
hinotify-bytestring,
hpath >= 0.7.1,
hsfm,
old-locale >= 1, old-locale >= 1,
process, process,
safe, safe,
simple-sendfile,
stm, stm,
time >= 1.4.2, time >= 1.4.2,
transformers, unix
unix,
unix-bytestring,
utf8-string,
word8
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
Default-Extensions: RecordWildCards Default-Extensions: RecordWildCards
@@ -94,9 +48,45 @@ executable hsfm-gtk
FlexibleInstances FlexibleInstances
ViewPatterns ViewPatterns
ghc-options: ghc-options:
-Wall -O2
-threaded
"-with-rtsopts=-N"
source-repository head executable hsfm-gtk
type: git main-is: GUI/Gtk.hs
location: https://github.com/hasufell/hsfm other-modules: GUI.Gtk.Callbacks
GUI.Gtk.Data
GUI.Gtk.Dialogs
GUI.Gtk.Icons
GUI.Gtk.Utils
MyPrelude
build-depends: hsfm,
base >= 4.7,
Cabal >= 1.22.0.0,
containers,
data-default,
gtk3 >= 0.14.1,
glib >= 0.13,
bifunctors >= 5,
directory >= 1.1.0.0 && < 1.2.3.0,
filepath >= 1.3.0.0,
hinotify,
mtl >= 2.2,
old-locale >= 1,
process,
safe,
stm,
time >= 1.4.2,
transformers,
unix
hs-source-dirs: src
default-language: Haskell2010
Default-Extensions: RecordWildCards
PatternSynonyms
FlexibleInstances
ViewPatterns
ghc-options:
-O2
-threaded
"-with-rtsopts=-N"

797
src/Data/DirTree.hs Normal file
View File

@@ -0,0 +1,797 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides data types for representing directories/files
-- and related operations on it, mostly internal stuff, not actual IO actions.
--
-- It doesn't allow to represent the whole filesystem, since that's only
-- possible through IO laziness, which introduces too much internal state.
module Data.DirTree where
import Control.Applicative
(
(<*>)
, (<$>)
, (<|>)
, pure
)
import Control.Arrow
(
first
)
import Control.Exception
(
handle
)
import Control.Exception.Base
(
IOException
)
import Control.Monad.State.Lazy
(
)
import Data.Default
import Data.List
(
delete
, foldl'
, isPrefixOf
, sort
, sortBy
, (\\)
)
import Data.Maybe
(
fromMaybe
)
import Data.Ord
(
comparing
)
import Data.Time.Clock.POSIX
(
POSIXTime
, posixSecondsToUTCTime
)
import Data.Traversable
(
for
)
import Data.Word
(
Word64
)
import Safe
(
atDef
, initDef
)
import System.FilePath
(
combine
, normalise
, equalFilePath
, isAbsolute
, joinPath
, pathSeparator
, splitDirectories
, takeFileName
, (</>)
)
import System.IO
(
IOMode
, Handle
, openFile
)
import System.IO.Error
(
ioeGetErrorType
, isDoesNotExistErrorType
)
import System.IO.Unsafe
(
unsafeInterleaveIO
)
import System.Locale
(
defaultTimeLocale
, rfc822DateFormat
)
import System.Posix.Types
(
DeviceID
, EpochTime
, FileID
, FileMode
, FileOffset
, GroupID
, LinkCount
, UserID
)
import qualified Data.Bitraversable as BT
import qualified Data.Bifunctor as BF
import qualified Data.Bifoldable as BFL
import qualified Data.Traversable as T
import qualified System.Posix.Files as PF
import qualified System.Posix.Directory as PFD
----------------------------
--[ BASE TYPES ]--
----------------------------
-- |Weak type to distinguish between FilePath and FileName.
type FileName = String
-- |Represents a file. The `anchor` field is the path
-- to that file without the filename.
data AnchoredFile a =
(:/) { anchor :: FilePath, file :: File a }
deriving (Eq, Show)
-- |The String in the name field is always a file name, never a full path.
-- The free type variable is used in the File/Dir constructor and can hold
-- Handles, Strings representing a file's contents or anything else you can
-- think of. We catch any IO errors in the Failed constructor. an Exception
-- can be converted to a String with 'show'.
data File a =
Failed {
name :: FileName
, err :: IOException
}
| Dir {
name :: FileName
, fvar :: a
}
| RegFile {
name :: FileName
, fvar :: a
}
| SymLink {
name :: FileName
, fvar :: a
, sdest :: AnchoredFile a -- ^ symlink madness,
-- we need to know where it points to
}
| BlockDev {
name :: FileName
, fvar :: a
}
| CharDev {
name :: FileName
, fvar :: a
}
| NamedPipe {
name :: FileName
, fvar :: a
}
| Socket {
name :: FileName
, fvar :: a
} deriving (Show, Eq)
-- |All possible file information we could ever need.
data FileInfo = FileInfo {
deviceID :: DeviceID
, fileID :: FileID
, fileMode :: FileMode
, linkCount :: LinkCount
, fileOwner :: UserID
, fileGroup :: GroupID
, specialDeviceID :: DeviceID
, fileSize :: FileOffset
, accessTime :: EpochTime
, modificationTime :: EpochTime
, statusChangeTime :: EpochTime
, accessTimeHiRes :: POSIXTime
, modificationTimeHiRes :: POSIXTime
, statusChangeTimeHiRes :: POSIXTime
} deriving (Show, Eq, Ord)
type UserIO a = FilePath -> IO a
type Builder a = UserIO a -> FilePath -> IO [File a]
------------------------------------
--[ ViewPatterns/PatternSynonyms ]--
------------------------------------
convertViewP :: (File FileInfo -> (Bool, File FileInfo))
-> AnchoredFile FileInfo
-> (Bool, AnchoredFile FileInfo)
convertViewP f af@(bp :/ constr) =
let (b, file) = f constr
in (b, bp :/ file)
afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLike f@(bp :/ constr) = convertViewP fileLike f
fileLike :: File FileInfo -> (Bool, File FileInfo)
fileLike f@(RegFile {}) = (True, f)
fileLike f@(BlockDev {}) = (True, f)
fileLike f@(CharDev {}) = (True, f)
fileLike f@(NamedPipe {}) = (True, f)
fileLike f@(Socket {}) = (True, f)
fileLike f = (False, f)
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
sadir f = convertViewP sdir f
sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
-- we have to follow a chain of symlinks here, but
-- return only the very first level
= case (sdir s) of
(True, _) -> (True, f)
_ -> (False, f)
sdir f@(SymLink { sdest = (_ :/ Dir {} )})
= (True, f)
sdir f@(Dir {}) = (True, f)
sdir f = (False, f)
safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safileLike f = convertViewP sfileLike f
sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@(RegFile {}) = (True, f)
sfileLike f@(BlockDev {}) = (True, f)
sfileLike f@(CharDev {}) = (True, f)
sfileLike f@(NamedPipe {}) = (True, f)
sfileLike f@(Socket {}) = (True, f)
sfileLike f = fileLikeSym f
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLikeSym f = convertViewP fileLikeSym f
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
= case (fileLikeSym s) of
(True, _) -> (True, f)
_ -> (False, f)
fileLikeSym f@(SymLink { sdest = (_ :/ RegFile {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ BlockDev {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ CharDev {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ NamedPipe {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ Socket {} )}) = (True, f)
fileLikeSym f = (False, f)
adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
adirSym f = convertViewP dirSym f
dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
= case (dirSym s) of
(True, _) -> (True, f)
_ -> (False, f)
dirSym f@(SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
dirSym f = (False, f)
invalidFileName :: FileName -> (Bool, FileName)
invalidFileName "" = (True, "")
invalidFileName "." = (True, ".")
invalidFileName ".." = (True, "..")
invalidFileName fn = (elem pathSeparator fn, fn)
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
abrokenSymlink f = convertViewP brokenSymlink f
brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
brokenSymlink f = (isBrokenSymlink f, f)
-- |Matches on invalid filesnames, such as ".", ".." and anything
-- that contains a path separator.
pattern InvFN <- (invalidFileName -> (True,_))
-- |Opposite of `InvFN`.
pattern ValFN f <- (invalidFileName -> (False, f))
-- |Matches on directories or symlinks pointing to directories.
-- If the symlink is pointing to a symlink pointing to a directory, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern ADirOrSym f <- (sadir -> (True, f))
pattern DirOrSym f <- (sdir -> (True, f))
-- |Matches on symlinks pointing to directories only.
pattern ADirSym f <- (adirSym -> (True, f))
pattern DirSym f <- (dirSym -> (True, f))
-- |Matches on any non-directory kind of files or symlinks pointing to
-- such.
-- If the symlink is pointing to a symlink pointing to such a file, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern AFileLikeOrSym f <- (safileLike -> (True, f))
pattern FileLikeOrSym f <- (sfileLike -> (True, f))
-- |Matches on any non-directory kind of files, excluding symlinks.
pattern AFileLike f <- (afileLike -> (True, f))
pattern FileLike f <- (fileLike -> (True, f))
-- |Matches on symlinks pointing to file-like files only.
pattern AFileLikeSym f <- (afileLikeSym -> (True, f))
pattern FileLikeSym f <- (fileLikeSym -> (True, f))
-- |Matches on broken symbolic links.
pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-----------------
--[ INSTANCES ]--
-----------------
-- | First compare constructors: Failed < Dir < File...
-- Then compare `name`...
-- Then compare free variable parameter of `File` constructors
instance Ord (File FileInfo) where
compare (RegFile n a) (RegFile n' a') =
case compare n n' of
EQ -> compare a a'
el -> el
compare (Dir n b) (Dir n' b') =
case compare n n' of
EQ -> compare b b'
el -> el
-- after comparing above we can hand off to shape ord function:
compare d d' = comparingConstr d d'
-- |First compare anchor, then compare File.
instance Ord (AnchoredFile FileInfo) where
compare (bp1 :/ a) (bp2 :/ b) =
case compare bp1 bp2 of
EQ -> compare a b
el -> el
----------------------------
--[ HIGH LEVEL FUNCTIONS ]--
----------------------------
-- |Read a file into an `AnchoredFile`, filling the free variables via
-- the given function.
readFileWith :: (FilePath -> IO a)
-> FilePath
-> IO (AnchoredFile a)
readFileWith ff p = do
let fn = topDir p
bd = baseDir p
handleDT' bd fn $ do
fs <- PF.getSymbolicLinkStatus p
fv <- ff p
file <- constructFile fs fv bd fn
return (bd :/ file)
where
constructFile fs fv bd' n
| PF.isSymbolicLink fs = do
-- symlink madness, we need to make sure we save the correct
-- AnchoredFile
let fp = bd' </> n
resolvedSyml <- handleDT' bd' n $ do
sfp <- (\x -> if isAbsolute x then x else bd' </> x)
<$> PF.readSymbolicLink fp
_ <- PF.getFileStatus sfp -- important to break infinite symbolic
-- link cycle
readFileWith ff sfp
return $ SymLink n fv resolvedSyml
| PF.isDirectory fs = return $ Dir n fv
| PF.isRegularFile fs = return $ RegFile n fv
| PF.isBlockDevice fs = return $ BlockDev n fv
| PF.isCharacterDevice fs = return $ CharDev n fv
| PF.isNamedPipe fs = return $ NamedPipe n fv
| PF.isSocket fs = return $ Socket n fv
| otherwise = return $ Failed n (userError
"Unknown filetype!")
readFile :: FilePath -> IO (AnchoredFile FileInfo)
readFile fp = readFileWith getFileInfo $ normalize fp
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This includes the "." and ".."
-- directories.
readDirectory :: FilePath -> IO [AnchoredFile FileInfo]
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo
$ normalize fp
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This excludes the "." and ".."
-- directories.
readDirectory' :: FilePath -> IO [AnchoredFile FileInfo]
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo
$ normalize fp
-- | same as readDirectory but allows us to, for example, use
-- ByteString.readFile to return a tree of ByteStrings.
readDirectoryWith :: (FilePath -> IO [FilePath])
-> (FilePath -> IO a)
-> FilePath
-> IO [AnchoredFile a]
readDirectoryWith getfiles ff p = do
contents <- getfiles $ normalize p
cs <- mapM (\x -> readFileWith ff $ p </> x) contents
return $ removeNonexistent cs
-----------------
--[ UTILITIES ]--
-----------------
---- HANDLING FAILURES ----
-- | True if any Failed constructors in the tree
anyFailed :: [File a] -> Bool
anyFailed = not . successful
-- | True if there are no Failed constructors in the tree
successful :: [File a] -> Bool
successful = null . failures
-- | returns true if argument is a `Failed` constructor:
failed :: File a -> Bool
failed (Failed _ _) = True
failed _ = False
-- | returns a list of 'Failed' constructors only:
failures :: [File a] -> [File a]
failures = filter failed
---- ORDERING AND EQUALITY ----
-- HELPER: a non-recursive comparison
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
comparingConstr (Failed _ _) (DirOrSym _) = LT
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
comparingConstr (DirOrSym _) (Failed _ _) = GT
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
-- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors:
comparingConstr t t' = compare (name t) (name t')
---- OTHER ----
---------------
--[ HELPERS ]--
---------------
---- CONSTRUCTOR IDENTIFIERS ----
isFileC :: File a -> Bool
isFileC (RegFile _ _) = True
isFileC _ = False
isDirC :: File a -> Bool
isDirC (Dir _ _) = True
isDirC _ = False
isSymC :: File a -> Bool
isSymC (SymLink _ _ _) = True
isSymC _ = False
isBlockC :: File a -> Bool
isBlockC (BlockDev _ _) = True
isBlockC _ = False
isCharC :: File a -> Bool
isCharC (CharDev _ _) = True
isCharC _ = False
isNamedC :: File a -> Bool
isNamedC (NamedPipe _ _) = True
isNamedC _ = False
isSocketC :: File a -> Bool
isSocketC (Socket _ _) = True
isSocketC _ = False
---- PATH CONVERSIONS ----
-- extracting pathnames and base names:
topDir, baseDir :: FilePath -> FilePath
topDir = last . splitDirectories
baseDir = joinPath . init . splitDirectories
-- |Check whether the given file is a hidden file.
hiddenFile :: FilePath -> Bool
hiddenFile "." = False
hiddenFile ".." = False
hiddenFile str
| "." `isPrefixOf` str = True
| otherwise = False
-- |Like `normalise` from System.FilePath but removes occurences of '..'.
-- Note that this sort of misbehaves if the path contains symlink
-- components.
normalize :: FilePath -> FilePath
normalize fp =
joinPath $ foldl' ff [] (splitDirectories . normalise $ fp)
where
ff ["/"] ".." = ["/"]
ff x ".." = initDef [] x
ff x y = x ++ [y]
---- IO HELPERS: ----
-- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
goUp af@("" :/ _) = return af
goUp (bp :/ _) = Data.DirTree.readFile bp
-- |Go up one directory in the filesystem hierarchy.
goUp' :: FilePath -> IO (AnchoredFile FileInfo)
goUp' fp = do
let cfp = normalize fp
Data.DirTree.readFile $ baseDir cfp
-- |Get the contents of a directory.
getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents (ADirOrSym af) = readDirectory (fullPath af)
getContents _ = return []
-- |Get all files of a given directory and return them as a List.
-- This includes "." and "..".
getAllDirsFiles :: FilePath -> IO [FilePath]
getAllDirsFiles fp = do
dirstream <- PFD.openDirStream fp
let mdirs :: [FilePath] -> IO [FilePath]
mdirs dirs = do
dir <- PFD.readDirStream dirstream
if dir == ""
then return dirs
else mdirs (dir : dirs)
dirs <- mdirs []
PFD.closeDirStream dirstream
return dirs
-- |Get all files of a given directory and return them as a List.
-- This excludes "." and "..".
getDirsFiles :: FilePath -> IO [FilePath]
getDirsFiles fp = do
dirstream <- PFD.openDirStream fp
let mdirs :: [FilePath] -> IO [FilePath]
mdirs dirs = do
dir <- PFD.readDirStream dirstream
if dir == ""
then return dirs
else mdirs (insert dir dirs)
dirs <- mdirs []
PFD.closeDirStream dirstream
return dirs
where
insert dir dirs = case dir of
"." -> dirs
".." -> dirs
_ -> dir : dirs
-- |Gets all file information.
getFileInfo :: FilePath -> IO FileInfo
getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus fp
return $ FileInfo
(PF.deviceID fs)
(PF.fileID fs)
(PF.fileMode fs)
(PF.linkCount fs)
(PF.fileOwner fs)
(PF.fileGroup fs)
(PF.specialDeviceID fs)
(PF.fileSize fs)
(PF.accessTime fs)
(PF.modificationTime fs)
(PF.statusChangeTime fs)
(PF.accessTimeHiRes fs)
(PF.modificationTimeHiRes fs)
(PF.statusChangeTimeHiRes fs)
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: File a -> Maybe a
getFreeVar (Dir _ d) = Just d
getFreeVar (RegFile _ d) = Just d
getFreeVar (SymLink _ d _) = Just d
getFreeVar (BlockDev _ d) = Just d
getFreeVar (CharDev _ d) = Just d
getFreeVar (NamedPipe _ d) = Just d
getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing
---- FAILURE HELPERS: ----
-- handles an IO exception by returning a Failed constructor filled with that
-- exception:
handleDT :: FileName -> IO (File a) -> IO (File a)
handleDT n = handle (return . Failed n)
-- handles an IO exception by returning a Failed constructor filled with that
-- exception:
handleDT' :: FilePath -> FileName -> IO (AnchoredFile a) -> IO (AnchoredFile a)
handleDT' bp n = handle (\e -> return $ bp :/ Failed n e)
-- DoesNotExist errors not present at the topmost level could happen if a
-- named file or directory is deleted after being listed by
-- getDirectoryContents but before we can get it into memory.
-- So we filter those errors out because the user should not see errors
-- raised by the internal implementation of this module:
-- This leaves the error if it exists in the top (user-supplied) level:
removeNonexistent :: [AnchoredFile a] -> [AnchoredFile a]
removeNonexistent = filter isOkConstructor
where
isOkConstructor (_ :/ c) = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
---- SYMLINK HELPERS: ----
-- |Follows a chain of symlinks until it finds a non-symlink. Note that
-- this can be caught in an infinite loop if the symlinks haven't been
-- constructed properly. This module however ensures that this cannot
-- happen.
followSymlink :: File FileInfo -> File FileInfo
followSymlink (SymLink _ _ (_ :/ b@(SymLink {}))) = followSymlink b
followSymlink af = af
-- |Checks if a symlink is broken by examining the constructor of the
-- symlink destination. This also follows the symlink chain.
--
-- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {})) = True
isBrokenSymlink af@(SymLink {})
= case followSymlink af of
(Failed {}) -> True
_ -> False
isBrokenSymlink _ = False
---- OTHER: ----
fullPath :: AnchoredFile a -> FilePath
fullPath (bp :/ f) = bp </> name f
-- |Apply a function on the free variable. If there is no free variable
-- for the given constructor the value from the `Default` class is used.
fromFreeVar :: (Default d) => (a -> d) -> File a -> d
fromFreeVar f df = maybeD f $ getFreeVar df
-- |A `maybe` flavor using the `Default` class.
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
maybeD = maybe def
-- |Pack the modification time into a string.
packModTime :: File FileInfo
-> String
packModTime = fromFreeVar
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
-- |Pack the permissions into a string, similar to what "ls -l" does.
packPermissions :: File FileInfo
-> String
packPermissions dt = fromFreeVar (pStr . fileMode) dt
where
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
where
typeModeStr
| hasFM PF.regularFileMode = "-"
| hasFM PF.directoryMode = "d"
| hasFM PF.symbolicLinkMode = "l"
| hasFM PF.socketMode = "s"
| hasFM PF.blockSpecialMode = "b"
| hasFM PF.characterSpecialMode = "c"
| hasFM PF.namedPipeMode = "p"
ownerModeStr = hasFmStr PF.ownerReadMode "r"
++ hasFmStr PF.ownerWriteMode "w"
++ hasFmStr PF.ownerExecuteMode "x"
groupModeStr = hasFmStr PF.groupReadMode "r"
++ hasFmStr PF.groupWriteMode "w"
++ hasFmStr PF.groupExecuteMode "x"
otherModeStr = hasFmStr PF.otherReadMode "r"
++ hasFmStr PF.otherWriteMode "w"
++ hasFmStr PF.otherExecuteMode "x"
hasFmStr fm str
| hasFM fm = str
| otherwise = "-"
hasFM fm = ffm `PF.intersectFileModes` fm == fm

293
src/GUI/Gtk.hs Normal file
View File

@@ -0,0 +1,293 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module Main where
import Control.Applicative
(
(<$>)
, (<*>)
)
import Control.Concurrent
(
forkIO
)
import Control.Concurrent.MVar
(
newEmptyMVar
)
import Control.Concurrent.STM
(
TVar
, newTVarIO
, readTVarIO
)
import Control.Exception
(
try
, Exception
, SomeException
)
import Control.Monad
(
when
, void
)
import Control.Monad.IO.Class
(
liftIO
)
import Data.DirTree
import Data.Foldable
(
for_
)
import Data.List
(
sort
, isPrefixOf
)
import Data.Maybe
(
fromJust
, catMaybes
, fromMaybe
)
import Data.Traversable
(
forM
)
import Graphics.UI.Gtk
import GUI.Gtk.Callbacks
import GUI.Gtk.Data
import GUI.Gtk.Dialogs
import GUI.Gtk.Icons
import GUI.Gtk.Utils
import IO.Error
import IO.File
import IO.Utils
import MyPrelude
import Safe
(
headDef
)
import System.Directory
(
doesFileExist
, doesDirectoryExist
)
import System.Environment
(
getArgs
)
import System.FilePath
(
isAbsolute
, (</>)
)
import System.Glib.UTFString
(
glibToString
)
import System.IO.Unsafe
(
unsafePerformIO
)
import System.Process
(
spawnProcess
)
-- TODO: simplify where we modify the TVars
-- TODO: double check garbage collection/gtk ref counting
-- TODO: file watching, when and what to reread
main :: IO ()
main = do
_ <- initGUI
args <- getArgs
startMainWindow (headDef "/" args)
_ <- mainGUI
return ()
-------------------------
--[ Main Window Setup ]--
-------------------------
-- |Set up the GUI.
--
-- Interaction with mutable references:
--
-- * 'settings' creates
-- * 'operationBuffer' creates
-- * 'rawModel' creates
-- * 'filteredModel' creates
-- * 'sortedModel' creates
startMainWindow :: FilePath -> IO ()
startMainWindow startdir = do
settings <- newTVarIO (MkFMSettings False True)
inotify <- newEmptyMVar
-- get the icons
iT <- iconThemeGetDefault
folderPix <- getIcon IFolder iT 24
folderSymPix <- getSymlinkIcon IFolder iT 24
filePix <- getIcon IFile iT 24
fileSymPix <- getSymlinkIcon IFile iT 24
errorPix <- getIcon IError iT 24
operationBuffer <- newTVarIO None
builder <- builderNew
builderAddFromFile builder "data/Gtk/builder.xml"
-- get the pre-defined gui widgets
rootWin <- builderGetObject builder castToWindow
"rootWin"
scroll <- builderGetObject builder castToScrolledWindow
"mainScroll"
menubarFileQuit <- builderGetObject builder castToImageMenuItem
"menubarFileQuit"
menubarFileOpen <- builderGetObject builder castToImageMenuItem
"menubarFileOpen"
menubarFileExecute <- builderGetObject builder castToImageMenuItem
"menubarFileExecute"
menubarFileNew <- builderGetObject builder castToImageMenuItem
"menubarFileNew"
menubarEditCut <- builderGetObject builder castToImageMenuItem
"menubarEditCut"
menubarEditCopy <- builderGetObject builder castToImageMenuItem
"menubarEditCopy"
menubarEditRename <- builderGetObject builder castToImageMenuItem
"menubarEditRename"
menubarEditPaste <- builderGetObject builder castToImageMenuItem
"menubarEditPaste"
menubarEditDelete <- builderGetObject builder castToImageMenuItem
"menubarEditDelete"
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
"menubarHelpAbout"
urlBar <- builderGetObject builder castToEntry
"urlBar"
statusBar <- builderGetObject builder castToStatusbar
"statusBar"
rcMenu <- builderGetObject builder castToMenu
"rcMenu"
rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNew <- builderGetObject builder castToImageMenuItem
"rcFileNew"
rcFileCut <- builderGetObject builder castToImageMenuItem
"rcFileCut"
rcFileCopy <- builderGetObject builder castToImageMenuItem
"rcFileCopy"
rcFileRename <- builderGetObject builder castToImageMenuItem
"rcFileRename"
rcFilePaste <- builderGetObject builder castToImageMenuItem
"rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete"
refreshView <- builderGetObject builder castToButton
"refreshView"
-- create initial list store model with unsorted data
-- we check that the startdir passed by the user is valid
-- TODO: maybe move this to a separate function
sd <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x)
then Data.DirTree.readFile "/"
else return x) =<< Data.DirTree.readFile startdir
rawModel <- newTVarIO =<< listStoreNew
=<< Data.DirTree.getContents sd
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
=<< readTVarIO rawModel
-- create an initial sorting proxy model
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
=<< readTVarIO filteredModel
-- create the final view
treeView <- treeViewNew
-- create final tree model columns
renderTxt <- cellRendererTextNew
renderPix <- cellRendererPixbufNew
let ct = cellText :: (CellRendererTextClass cr) => Attr cr String
cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
-- filename column
cF <- treeViewColumnNew
treeViewColumnSetTitle cF "Filename"
treeViewColumnSetResizable cF True
treeViewColumnSetClickable cF True
treeViewColumnSetSortColumnId cF 1
cellLayoutPackStart cF renderPix False
cellLayoutPackStart cF renderTxt True
_ <- treeViewAppendColumn treeView cF
cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
-- date column
cMD <- treeViewColumnNew
treeViewColumnSetTitle cMD "Date"
treeViewColumnSetResizable cMD True
treeViewColumnSetClickable cMD True
treeViewColumnSetSortColumnId cMD 2
cellLayoutPackStart cMD renderTxt True
_ <- treeViewAppendColumn treeView cMD
cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
-- permissions column
cP <- treeViewColumnNew
treeViewColumnSetTitle cP "Permission"
treeViewColumnSetResizable cP True
treeViewColumnSetClickable cP True
treeViewColumnSetSortColumnId cP 3
cellLayoutPackStart cP renderTxt True
_ <- treeViewAppendColumn treeView cP
cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
-- construct the gui object
let mygui = MkMyGUI {..}
let myview = MkMyView {..}
-- create the tree model with its contents
constructTreeView mygui myview
-- set the bindings
setCallbacks mygui myview
-- add the treeview to the scroll container
containerAdd scroll treeView
-- sets the default icon
windowSetDefaultIconFromFile "data/Gtk/icons/hsfm.png"
widgetShowAll rootWin

288
src/GUI/Gtk/Callbacks.hs Normal file
View File

@@ -0,0 +1,288 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Callbacks where
import Control.Applicative
(
(<$>)
, (<*>)
)
import Control.Concurrent.STM
(
TVar
, newTVarIO
, readTVarIO
)
import Control.Monad
(
void
)
import Control.Monad.IO.Class
(
liftIO
)
import Data.DirTree
import Data.Foldable
(
for_
)
import Graphics.UI.Gtk
import GUI.Gtk.Data
import GUI.Gtk.Dialogs
import GUI.Gtk.Utils
import IO.File
import IO.Utils
import System.Directory
(
doesFileExist
, doesDirectoryExist
)
import System.FilePath
(
isAbsolute
, (</>)
)
import System.Glib.UTFString
(
glibToString
)
-----------------
--[ Callbacks ]--
-----------------
-- |Set callbacks, on hotkeys, events and stuff.
--
-- Interaction with mutable references:
--
-- * 'settings mygui' modifies
setCallbacks :: MyGUI -> MyView -> IO ()
setCallbacks mygui myview = do
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> refreshTreeView' mygui myview cdir
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview del
_ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview copyInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"x" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview moveInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
liftIO $ operationFinal mygui myview
_ <- refreshView mygui `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview
refreshTreeView' mygui myview cdir
-- menubar-file
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- menubarFileOpen mygui `on` menuItemActivated $
liftIO $ withRow mygui myview open
_ <- menubarFileExecute mygui `on` menuItemActivated $
liftIO $ withRow mygui myview execute
_ <- menubarFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
-- menubar-edit
_ <- menubarEditCut mygui `on` menuItemActivated $
liftIO $ withRow mygui myview moveInit
_ <- menubarEditCopy mygui `on` menuItemActivated $
liftIO $ withRow mygui myview copyInit
_ <- menubarEditRename mygui `on` menuItemActivated $
liftIO $ withRow mygui myview renameF
_ <- menubarEditPaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- menubarEditDelete mygui `on` menuItemActivated $
liftIO $ withRow mygui myview del
-- menubar-help
_ <- menubarHelpAbout mygui `on` menuItemActivated $
liftIO showAboutDialog
-- righ-click
_ <- treeView mygui `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
RightButton -> liftIO $ menuPopup (rcMenu mygui) $ Just (RightButton, t)
_ -> return ()
return False
_ <- rcFileOpen mygui `on` menuItemActivated $
liftIO $ withRow mygui myview open
_ <- rcFileExecute mygui `on` menuItemActivated $
liftIO $ withRow mygui myview execute
_ <- rcFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
_ <- rcFileCopy mygui `on` menuItemActivated $
liftIO $ withRow mygui myview copyInit
_ <- rcFileRename mygui `on` menuItemActivated $
liftIO $ withRow mygui myview renameF
_ <- rcFilePaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- rcFileDelete mygui `on` menuItemActivated $
liftIO $ withRow mygui myview del
_ <- rcFileCut mygui `on` menuItemActivated $
liftIO $ withRow mygui myview moveInit
return ()
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar mygui)
let abs = isAbsolute fp
exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
-- TODO: more explicit error handling?
refreshTreeView mygui myview (Just fp)
-- |Supposed to be used with 'withRow'. Opens a file or directory.
open :: Row -> MyGUI -> MyView -> IO ()
open row mygui myview = withErrorDialog $
case row of
ADirOrSym r -> do
nv <- Data.DirTree.readFile $ fullPath r
refreshTreeView' mygui myview nv
r ->
void $ openFile r
-- |Execute a given file.
execute :: Row -> MyGUI -> MyView -> IO ()
execute row mygui myview = withErrorDialog $
void $ executeFile row []
-- |Supposed to be used with 'withRow'. Deletes a file or directory.
del :: Row -> MyGUI -> MyView -> IO ()
del row mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ fullPath row ++ "\"?"
withConfirmationDialog cmsg
$ easyDelete row
-- |Initializes a file move operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' writes
moveInit :: Row -> MyGUI -> MyView -> IO ()
moveInit row mygui myview =
writeTVarIO (operationBuffer myview) (FMove . MP1 $ row)
-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' writes
copyInit :: Row -> MyGUI -> MyView -> IO ()
copyInit row mygui myview =
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row)
-- |Finalizes a file operation, such as copy or move.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' reads
operationFinal :: MyGUI -> MyView -> IO ()
operationFinal mygui myview = withErrorDialog $ do
op <- readTVarIO (operationBuffer myview)
cdir <- getCurrentDir myview
case op of
FMove (MP1 s) -> do
let cmsg = "Really move \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
withConfirmationDialog cmsg
$ void $ runFileOp (FMove . MC s $ cdir)
return ()
FCopy (CP1 s) -> do
let cmsg = "Really copy \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
cm <- showCopyModeChooserDialog
withConfirmationDialog cmsg
$ void $ runFileOp (FCopy . CC s cdir $ cm)
return ()
_ -> return ()
-- |Go up one directory and visualize it in the treeView.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'sortedModel' reads
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
nv <- goUp cdir
refreshTreeView' mygui myview nv
-- |Go up one directory and visualize it in the treeView.
newFile :: MyGUI -> MyView -> IO ()
newFile mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name"
for_ mfn $ \fn -> do
cdir <- getCurrentDir myview
createFile cdir fn
renameF :: Row -> MyGUI -> MyView -> IO ()
renameF row mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name"
for_ mfn $ \fn -> do
let cmsg = "Really rename \"" ++ fullPath row
++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?"
withConfirmationDialog cmsg $ IO.File.renameFile row fn

111
src/GUI/Gtk/Data.hs Normal file
View File

@@ -0,0 +1,111 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Data where
import Control.Concurrent.MVar
(
MVar
)
import Control.Concurrent.STM
(
TVar
)
import Data.DirTree
import Graphics.UI.Gtk
import IO.File
import System.INotify
(
INotify
)
------------------
--[ Base Types ]--
------------------
-- |Monolithic object passed to various GUI functions in order
-- to keep the API stable and not alter the parameters too much.
-- This only holds GUI widgets that are needed to be read during
-- runtime.
data MyGUI = MkMyGUI {
-- |main Window
rootWin :: Window
, menubarFileQuit :: ImageMenuItem
, menubarFileOpen :: ImageMenuItem
, menubarFileExecute :: ImageMenuItem
, menubarFileNew :: ImageMenuItem
, menubarEditCut :: ImageMenuItem
, menubarEditCopy :: ImageMenuItem
, menubarEditRename :: ImageMenuItem
, menubarEditPaste :: ImageMenuItem
, menubarEditDelete :: ImageMenuItem
, menubarHelpAbout :: ImageMenuItem
, rcMenu :: Menu
, rcFileOpen :: ImageMenuItem
, rcFileExecute :: ImageMenuItem
, rcFileNew :: ImageMenuItem
, rcFileCut :: ImageMenuItem
, rcFileCopy :: ImageMenuItem
, rcFileRename :: ImageMenuItem
, rcFilePaste :: ImageMenuItem
, rcFileDelete :: ImageMenuItem
, refreshView :: Button
, urlBar :: Entry
, statusBar :: Statusbar
, treeView :: TreeView
-- |first column
, cF :: TreeViewColumn
-- |second column
, cMD :: TreeViewColumn
, renderTxt :: CellRendererText
, renderPix :: CellRendererPixbuf
, settings :: TVar FMSettings
, folderPix :: Pixbuf
, folderSymPix :: Pixbuf
, filePix :: Pixbuf
, fileSymPix :: Pixbuf
, errorPix :: Pixbuf
}
-- |FM-wide settings.
data FMSettings = MkFMSettings {
showHidden :: Bool
, isLazy :: Bool
}
type Row = AnchoredFile FileInfo
-- |This describes the contents of the treeView and is separated from MyGUI,
-- because we might want to have multiple views.
data MyView = MkMyView {
rawModel :: TVar (ListStore Row)
, sortedModel :: TVar (TypedTreeModelSort Row)
, filteredModel :: TVar (TypedTreeModelFilter Row)
, operationBuffer :: TVar FileOperation
, inotify :: MVar INotify
}

183
src/GUI/Gtk/Dialogs.hs Normal file
View File

@@ -0,0 +1,183 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Dialogs where
import Control.Applicative
(
(<$>)
)
import Control.Exception
(
try
, SomeException
)
import Control.Monad
(
when
, void
)
import Data.Version
(
showVersion
)
import Distribution.Package
(
PackageIdentifier(..)
, PackageName(..)
)
import Distribution.PackageDescription
(
GenericPackageDescription(..)
, PackageDescription(..)
)
import Distribution.PackageDescription.Parse
(
readPackageDescription
)
import Distribution.Verbosity
(
silent
)
import Graphics.UI.Gtk
import GUI.Gtk.Data
import IO.File
---------------------
--[ Dialog popups ]--
---------------------
-- |Pops up an error Dialog with the given String.
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
-- |Asks the user for confirmation and returns True/False.
showConfirmationDialog :: String -> IO Bool
showConfirmationDialog str = do
confirmDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsYesNo
str
rID <- dialogRun confirmDialog
widgetDestroy confirmDialog
case rID of
ResponseYes -> return True
ResponseNo -> return False
_ -> return False
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
showCopyModeChooserDialog :: IO DirCopyMode
showCopyModeChooserDialog = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
"Choose the copy mode"
dialogAddButton chooserDialog "Strict" (ResponseUser 0)
dialogAddButton chooserDialog "Merge" (ResponseUser 1)
dialogAddButton chooserDialog "Replace" (ResponseUser 2)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Strict
ResponseUser 1 -> return Merge
ResponseUser 2 -> return Replace
-- |Shows the about dialog from the help menu.
showAboutDialog :: IO ()
showAboutDialog = do
ad <- aboutDialogNew
lstr <- readFile "LICENSE"
hsfmicon <- pixbufNewFromFile "data/Gtk/icons/hsfm.png"
pdesc <- packageDescription <$> readPackageDescription silent "hsfm.cabal"
set ad
[ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc
, aboutDialogName := (unPackageName . pkgName . package) pdesc
, aboutDialogVersion := (showVersion . pkgVersion . package) pdesc
, aboutDialogCopyright := copyright pdesc
, aboutDialogComments := description pdesc
, aboutDialogLicense := Just lstr
, aboutDialogWebsite := homepage pdesc
, aboutDialogAuthors := [author pdesc]
, aboutDialogLogo := Just hsfmicon
, aboutDialogWrapLicense := True
]
_ <- dialogRun ad
widgetDestroy ad
-- |Carry out an IO action with a confirmation dialog.
-- If the user presses "No", then do nothing.
withConfirmationDialog :: String -> IO () -> IO ()
withConfirmationDialog str io = do
run <- showConfirmationDialog str
when run io
-- |Execute the given IO action. If the action throws exceptions,
-- visualize them via 'showErrorDialog'.
withErrorDialog :: IO a -> IO ()
withErrorDialog io = do
r <- try io
either (\e -> showErrorDialog $ show (e :: SomeException))
(\_ -> return ())
r
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
textInputDialog :: String -> IO (Maybe String)
textInputDialog title = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
title
entry <- entryNew
cbox <- dialogGetActionArea chooserDialog
dialogAddButton chooserDialog "Ok" (ResponseUser 0)
dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) entry PackNatural 5
widgetShowAll chooserDialog
rID <- dialogRun chooserDialog
ret <- case rID of
-- TODO: make this more safe
ResponseUser 0 -> Just <$> entryGetText entry
ResponseUser 1 -> return Nothing
widgetDestroy chooserDialog
return ret

27
src/HSFM/GUI/Gtk/Icons.hs → src/GUI/Gtk/Icons.hs
View File

@@ -1,6 +1,6 @@
{-- {--
HSFM, a filemanager written in Haskell. HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License modify it under the terms of the GNU General Public License
@@ -19,22 +19,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |Module for Gtk icon handling. -- |Module for Gtk icon handling.
module HSFM.GUI.Gtk.Icons where module GUI.Gtk.Icons where
import Control.Applicative
(
(<$>)
)
import Data.Maybe
(
fromJust
)
import Graphics.UI.Gtk import Graphics.UI.Gtk
import Paths_hsfm import Graphics.UI.Gtk.Gdk.Pixbuf
(
getDataFileName
)
-- |Icon type we use in our GUI. -- |Icon type we use in our GUI.
@@ -52,12 +41,10 @@ getIcon :: GtkIcon -- ^ icon we want
-> IO Pixbuf -> IO Pixbuf
getIcon icon itheme isize = do getIcon icon itheme isize = do
let iname = iconToStr icon let iname = iconToStr icon
hasicon <- iconThemeHasIcon itheme iname mpix <- iconThemeLoadIcon itheme iname isize IconLookupUseBuiltin
case hasicon of case mpix of
True -> fromJust <$> iconThemeLoadIcon itheme iname isize Just pix -> return pix
IconLookupUseBuiltin Nothing -> pixbufNewFromFile ("data/Gtk/icons/" ++ iname)
False -> pixbufNewFromFile =<< getDataFileName
("data/Gtk/icons/" ++ iname ++ ".png")
where where
iconToStr IFolder = "gtk-directory" iconToStr IFolder = "gtk-directory"
iconToStr IFile = "gtk-file" iconToStr IFile = "gtk-file"

294
src/GUI/Gtk/Utils.hs Normal file
View File

@@ -0,0 +1,294 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Utils where
import Control.Applicative
(
(<$>)
)
import Control.Concurrent.MVar
(
putMVar
, tryTakeMVar
)
import Control.Concurrent.STM
(
TVar
, newTVarIO
, readTVarIO
)
import Data.DirTree
import Data.Foldable
(
for_
)
import Data.List
(
isPrefixOf
)
import Data.Maybe
(
fromMaybe
, fromJust
)
import Data.Traversable
(
forM
)
import Graphics.UI.Gtk
import GUI.Gtk.Data
import IO.Error
import IO.Utils
import MyPrelude
import System.INotify
(
addWatch
, initINotify
, killINotify
, EventVariety(..)
, Event(..)
)
-----------------
--[ Utilities ]--
-----------------
-- |Gets the currently selected row of the treeView, if any.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'sortedModel' reads
-- * 'filteredModel' reads
getSelectedRow :: MyGUI
-> MyView
-> IO (Maybe Row)
getSelectedRow mygui myview = do
(tp, _) <- treeViewGetCursor $ treeView mygui
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
filteredModel' <- readTVarIO $ filteredModel myview
miter <- treeModelGetIter sortedModel' tp
forM miter $ \iter -> do
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
treeModelGetRow rawModel' cIter
-- |Carry out an action on the currently selected row.
--
-- If there is no row selected, does nothing.
withRow :: MyGUI
-> MyView
-> ( Row
-> MyGUI
-> MyView
-> IO ()) -- ^ action to carry out
-> IO ()
withRow mygui myview io = do
mrow <- getSelectedRow mygui myview
for_ mrow $ \row -> io row mygui myview
-- |Create the 'ListStore' of files/directories from the current directory.
-- This is the function which maps the Data.DirTree data structures
-- into the GTK+ data structures.
fileListStore :: AnchoredFile FileInfo -- ^ current dir
-> MyView
-> IO (ListStore Row)
fileListStore dt myview = do
cs <- Data.DirTree.getContents dt
listStoreNew cs
-- |Currently unsafe. This is used to obtain any row (possibly the '.' row)
-- and extract the "current working directory" from it.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
getFirstRow :: MyView
-> IO (AnchoredFile FileInfo)
getFirstRow myview = do
rawModel' <- readTVarIO $ rawModel myview
iter <- fromJust <$> treeModelGetIterFirst rawModel'
treeModelGetRow rawModel' iter
-- |Currently unsafe. Gets the current directory via `getFirstRow` and `goUp`.
getCurrentDir :: MyView
-> IO (AnchoredFile FileInfo)
getCurrentDir myview = getFirstRow myview >>= goUp
-- |Re-reads the current directory or the given one and updates the TreeView.
--
-- The operation may fail with:
--
-- * 'DirDoesNotExist' if the target directory does not exist
-- * 'PathNotAbsolute' if the target directory is not absolute
--
-- Interaction with mutable references:
--
-- * 'rawModel' writes
refreshTreeView :: MyGUI
-> MyView
-> Maybe FilePath
-> IO ()
refreshTreeView mygui myview mfp = do
mcdir <- getFirstRow myview
let fp = fromMaybe (anchor mcdir) mfp
-- get selected rows
tvs <- treeViewGetSelection (treeView mygui)
srows <- treeSelectionGetSelectedRows tvs
-- TODO catch exceptions
dirSanityThrow fp
newFsState <- Data.DirTree.readFile fp
newRawModel <- fileListStore newFsState myview
writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview
-- reselect selected rows
mapM_ (treeSelectionSelectPath tvs) srows
-- |Refreshes the TreeView based on the given directory.
--
-- Interaction with mutable references:
--
-- * 'rawModel' writes
refreshTreeView' :: MyGUI
-> MyView
-> AnchoredFile FileInfo
-> IO ()
refreshTreeView' mygui myview dt = do
newRawModel <- fileListStore dt myview
writeTVarIO (rawModel myview) newRawModel
-- get selected rows
tvs <- treeViewGetSelection (treeView mygui)
srows <- treeSelectionGetSelectedRows tvs
constructTreeView mygui myview
-- reselect selected rows
mapM_ (treeSelectionSelectPath tvs) srows
-- TODO: make this function more slim so only the most necessary parts are
-- called
-- |Constructs the visible TreeView with the current underlying mutable models,
-- which are retrieved from 'MyGUI'.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'filteredModel' writes
-- * 'sortedModel' writes
-- * 'settings' reads
constructTreeView :: MyGUI
-> MyView
-> IO ()
constructTreeView mygui myview = do
let treeView' = treeView mygui
cF' = cF mygui
cMD' = cMD mygui
render' = renderTxt mygui
cdirp <- anchor <$> getFirstRow myview
-- update urlBar
entrySetText (urlBar mygui) cdirp
rawModel' <- readTVarIO $ rawModel myview
-- filtering
filteredModel' <- treeModelFilterNew rawModel' []
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
row <- (name . file) <$> treeModelGetRow rawModel' iter
if hidden
then return True
else return $ not . hiddenFile $ row
-- sorting
sortedModel' <- treeModelSortNewWithModel filteredModel'
writeTVarIO (sortedModel myview) sortedModel'
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
row1 <- treeModelGetRow rawModel' cIter1
row2 <- treeModelGetRow rawModel' cIter2
return $ compare row1 row2
treeSortableSetSortColumnId sortedModel' 1 SortAscending
-- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . file)
treeModelSetColumn rawModel' (makeColumnIdString 1)
(name . file)
treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . file)
treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . file)
-- update treeview model
treeViewSetModel treeView' sortedModel'
-- add watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
newi <- initINotify
w <- addWatch
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
cdirp
(\_ -> postGUIAsync $ refreshTreeView mygui myview (Just cdirp))
putMVar (inotify myview) newi
return ()
where
dirtreePix (Dir {}) = folderPix mygui
dirtreePix (FileLike {}) = filePix mygui
dirtreePix (DirSym _) = folderSymPix mygui
dirtreePix (FileLikeSym {}) = fileSymPix mygui
dirtreePix (Failed {}) = errorPix mygui
dirtreePix (BrokenSymlink _) = errorPix mygui
dirtreePix _ = errorPix mygui
-- |Push a message to the status bar.
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
pushStatusBar mygui str = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
mid <- statusbarPush sb cid str
return (cid, mid)

614
src/HSFM/FileSystem/FileType.hs
View File

@@ -1,614 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides a data type for representing directories/files
-- in a well-typed and convenient way. This is useful to gather and
-- save information about a file, so the information can be easily
-- processed in e.g. a GUI.
--
-- However, it's not meant to be used to interact with low-level
-- functions that copy files etc, since there's no guarantee that
-- the in-memory representation of the type still matches what is
-- happening on filesystem level.
--
-- If you interact with low-level libraries, you must not pattern
-- match on the `File a` type. Instead, you should only use the saved
-- `path` and make no assumptions about the file the path might or
-- might not point to.
module HSFM.FileSystem.FileType where
import Data.ByteString(ByteString)
import Data.ByteString.UTF8
(
toString
)
import Data.Default
import Data.Time.Clock.POSIX
(
POSIXTime
, posixSecondsToUTCTime
)
import Data.Time()
import HPath
(
Abs
, Path
)
import qualified HPath as P
import HPath.IO hiding (FileType(..))
import HPath.IO.Errors
import HSFM.Utils.MyPrelude
import Prelude hiding(readFile)
import System.IO.Error
(
ioeGetErrorType
, isDoesNotExistErrorType
)
import System.Posix.FilePath
(
(</>)
)
import System.Posix.Directory.Traversals
(
realpath
)
import qualified System.Posix.Files.ByteString as PF
import System.Posix.Types
(
DeviceID
, EpochTime
, FileID
, FileMode
, FileOffset
, GroupID
, LinkCount
, UserID
)
----------------------------
--[ BASE TYPES ]--
----------------------------
-- |The String in the path field is always a full path.
-- The free type variable is used in the File/Dir constructor and can hold
-- Handles, Strings representing a file's contents or anything else you can
-- think of. We catch any IO errors in the Failed constructor.
data File a =
Failed {
path :: !(Path Abs)
, err :: IOError
}
| Dir {
path :: !(Path Abs)
, fvar :: a
}
| RegFile {
path :: !(Path Abs)
, fvar :: a
}
| SymLink {
path :: !(Path Abs)
, fvar :: a
, sdest :: File a -- ^ symlink madness,
-- we need to know where it points to
, rawdest :: !ByteString
}
| BlockDev {
path :: !(Path Abs)
, fvar :: a
}
| CharDev {
path :: !(Path Abs)
, fvar :: a
}
| NamedPipe {
path :: !(Path Abs)
, fvar :: a
}
| Socket {
path :: !(Path Abs)
, fvar :: a
} deriving (Show, Eq)
-- |Low-level file information.
data FileInfo = FileInfo {
deviceID :: !DeviceID
, fileID :: !FileID
, fileMode :: !FileMode
, linkCount :: !LinkCount
, fileOwner :: !UserID
, fileGroup :: !GroupID
, specialDeviceID :: !DeviceID
, fileSize :: !FileOffset
, accessTime :: !EpochTime
, modificationTime :: !EpochTime
, statusChangeTime :: !EpochTime
, accessTimeHiRes :: !POSIXTime
, modificationTimeHiRes :: !POSIXTime
, statusChangeTimeHiRes :: !POSIXTime
} deriving (Show, Eq, Ord)
------------------------------------
--[ ViewPatterns/PatternSynonyms ]--
------------------------------------
---- Filetypes ----
sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@RegFile{} = (True, f)
sfileLike f@BlockDev{} = (True, f)
sfileLike f@CharDev{} = (True, f)
sfileLike f@NamedPipe{} = (True, f)
sfileLike f@Socket{} = (True, f)
sfileLike f = fileLikeSym f
fileLike :: File FileInfo -> (Bool, File FileInfo)
fileLike f@RegFile {} = (True, f)
fileLike f@BlockDev{} = (True, f)
fileLike f@CharDev{} = (True, f)
fileLike f@NamedPipe{} = (True, f)
fileLike f@Socket{} = (True, f)
fileLike f = (False, f)
sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@SymLink{ sdest = (s@SymLink{} )}
-- we have to follow a chain of symlinks here, but
-- return only the very first level
-- TODO: this is probably obsolete now
= case sdir s of
(True, _) -> (True, f)
_ -> (False, f)
sdir f@SymLink{ sdest = Dir{} }
= (True, f)
sdir f@Dir{} = (True, f)
sdir f = (False, f)
-- |Matches on any non-directory kind of files, excluding symlinks.
pattern FileLike f <- (fileLike -> (True, f))
-- |Matches a list of directories or symlinks pointing to directories.
pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
-> (True, fs))
-- |Matches a list of any non-directory kind of files or symlinks
-- pointing to such.
pattern FileLikeList fs <- (\fs -> (and
. fmap (fst . sfileLike)
$ fs, fs) -> (True, fs))
---- Symlinks ----
brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
brokenSymlink f = (isBrokenSymlink f, f)
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@SymLink{ sdest = s@SymLink{} }
= case fileLikeSym s of
(True, _) -> (True, f)
_ -> (False, f)
fileLikeSym f@SymLink{ sdest = RegFile{} } = (True, f)
fileLikeSym f@SymLink{ sdest = BlockDev{} } = (True, f)
fileLikeSym f@SymLink{ sdest = CharDev{} } = (True, f)
fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
fileLikeSym f@SymLink{ sdest = Socket{} } = (True, f)
fileLikeSym f = (False, f)
dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@SymLink{ sdest = s@SymLink{} }
= case dirSym s of
(True, _) -> (True, f)
_ -> (False, f)
dirSym f@SymLink{ sdest = Dir{} } = (True, f)
dirSym f = (False, f)
-- |Matches on symlinks pointing to file-like files only.
pattern FileLikeSym f <- (fileLikeSym -> (True, f))
-- |Matches on broken symbolic links.
pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-- |Matches on directories or symlinks pointing to directories.
-- If the symlink is pointing to a symlink pointing to a directory, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern DirOrSym f <- (sdir -> (True, f))
-- |Matches on symlinks pointing to directories only.
pattern DirSym f <- (dirSym -> (True, f))
-- |Matches on any non-directory kind of files or symlinks pointing to
-- such.
-- If the symlink is pointing to a symlink pointing to such a file, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern FileLikeOrSym f <- (sfileLike -> (True, f))
-----------------
--[ INSTANCES ]--
-----------------
-- | First compare constructors: Failed < Dir < File...
-- Then compare `name`...
-- Then compare free variable parameter of `File` constructors
instance Ord (File FileInfo) where
compare (RegFile n a) (RegFile n' a') =
case compare n n' of
EQ -> compare a a'
el -> el
compare (Dir n b) (Dir n' b') =
case compare n n' of
EQ -> compare b b'
el -> el
-- after comparing above we can hand off to shape ord function:
compare d d' = comparingConstr d d'
----------------------------
--[ HIGH LEVEL FUNCTIONS ]--
----------------------------
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- variables via the given function.
readFile :: (Path Abs -> IO a)
-> Path Abs
-> IO (File a)
readFile ff p =
handleDT p $ do
fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
fv <- ff p
constructFile fs fv p
where
constructFile fs fv p'
| PF.isSymbolicLink fs = do
-- symlink madness, we need to make sure we save the correct
-- File
x <- PF.readSymbolicLink (P.fromAbs p')
resolvedSyml <- handleDT p' $ do
-- watch out, we call </> from 'filepath' here, but it is safe
let sfp = (P.fromAbs . P.dirname $ p') </> x
rsfp <- realpath sfp
readFile ff =<< P.parseAbs rsfp
return $ SymLink p' fv resolvedSyml x
| PF.isDirectory fs = return $ Dir p' fv
| PF.isRegularFile fs = return $ RegFile p' fv
| PF.isBlockDevice fs = return $ BlockDev p' fv
| PF.isCharacterDevice fs = return $ CharDev p' fv
| PF.isNamedPipe fs = return $ NamedPipe p' fv
| PF.isSocket fs = return $ Socket p' fv
| otherwise = return $ Failed p' (userError
"Unknown filetype!")
-- |Get the contents of a given directory and return them as a list
-- of `AnchoredFile`.
readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable
-> Path Abs -- ^ path to read
-> IO [File a]
readDirectoryContents ff p = do
files <- getDirsFiles p
fcs <- mapM (readFile ff) files
return fcs
-- |A variant of `readDirectoryContents` where the second argument
-- is a `File`. If a non-directory is passed returns an empty list.
getContents :: (Path Abs -> IO a)
-> File FileInfo
-> IO [File a]
getContents ff (DirOrSym af)
= readDirectoryContents ff (path af)
getContents _ _ = return []
-- |Go up one directory in the filesystem hierarchy.
goUp :: File FileInfo -> IO (File FileInfo)
goUp file = readFile getFileInfo (P.dirname . path $ file)
-- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (File FileInfo)
goUp' fp = readFile getFileInfo $ P.dirname fp
-----------------
--[ UTILITIES ]--
-----------------
---- HANDLING FAILURES ----
-- |True if any Failed constructors in the tree.
anyFailed :: [File a] -> Bool
anyFailed = not . successful
-- |True if there are no Failed constructors in the tree.
successful :: [File a] -> Bool
successful = null . failures
-- |Returns true if argument is a `Failed` constructor.
failed :: File a -> Bool
failed (Failed _ _) = True
failed _ = False
-- |Returns a list of 'Failed' constructors only.
failures :: [File a] -> [File a]
failures = filter failed
---- ORDERING AND EQUALITY ----
-- HELPER: a non-recursive comparison
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
comparingConstr (Failed _ _) (DirOrSym _) = LT
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
comparingConstr (DirOrSym _) (Failed _ _) = GT
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
-- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors:
comparingConstr t t' = compare (path t) (path t')
---------------
--[ HELPERS ]--
---------------
---- CONSTRUCTOR IDENTIFIERS ----
isFileC :: File a -> Bool
isFileC RegFile{} = True
isFileC _ = False
isDirC :: File a -> Bool
isDirC Dir{} = True
isDirC _ = False
isSymC :: File a -> Bool
isSymC SymLink{} = True
isSymC _ = False
isBlockC :: File a -> Bool
isBlockC BlockDev{} = True
isBlockC _ = False
isCharC :: File a -> Bool
isCharC CharDev{} = True
isCharC _ = False
isNamedC :: File a -> Bool
isNamedC NamedPipe{} = True
isNamedC _ = False
isSocketC :: File a -> Bool
isSocketC Socket{} = True
isSocketC _ = False
---- IO HELPERS: ----
-- |Gets all file information.
getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ FileInfo
(PF.deviceID fs)
(PF.fileID fs)
(PF.fileMode fs)
(PF.linkCount fs)
(PF.fileOwner fs)
(PF.fileGroup fs)
(PF.specialDeviceID fs)
(PF.fileSize fs)
(PF.accessTime fs)
(PF.modificationTime fs)
(PF.statusChangeTime fs)
(PF.accessTimeHiRes fs)
(PF.modificationTimeHiRes fs)
(PF.statusChangeTimeHiRes fs)
---- FAILURE HELPERS: ----
-- Handles an IO exception by returning a Failed constructor filled with that
-- exception. Does not handle FmIOExceptions.
handleDT :: Path Abs
-> IO (File a)
-> IO (File a)
handleDT p
= handleIOError $ \e -> return $ Failed p e
---- SYMLINK HELPERS: ----
-- |Checks if a symlink is broken by examining the constructor of the
-- symlink destination.
--
-- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink (SymLink _ _ Failed{} _) = True
isBrokenSymlink _ = False
---- PACKERS: ----
-- |Pack the modification time into a string.
packModTime :: File FileInfo
-> String
packModTime = fromFreeVar $ epochToString . modificationTime
-- |Pack the modification time into a string.
packAccessTime :: File FileInfo
-> String
packAccessTime = fromFreeVar $ epochToString . accessTime
epochToString :: EpochTime -> String
epochToString = show . posixSecondsToUTCTime . realToFrac
-- |Pack the permissions into a string, similar to what "ls -l" does.
packPermissions :: File FileInfo
-> String
packPermissions dt = fromFreeVar (pStr . fileMode) dt
where
pStr :: FileMode -> String
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
where
typeModeStr = case dt of
Dir {} -> "d"
RegFile {} -> "-"
SymLink {} -> "l"
BlockDev {} -> "b"
CharDev {} -> "c"
NamedPipe {} -> "p"
Socket {} -> "s"
_ -> "?"
ownerModeStr = hasFmStr PF.ownerReadMode "r"
++ hasFmStr PF.ownerWriteMode "w"
++ hasFmStr PF.ownerExecuteMode "x"
groupModeStr = hasFmStr PF.groupReadMode "r"
++ hasFmStr PF.groupWriteMode "w"
++ hasFmStr PF.groupExecuteMode "x"
otherModeStr = hasFmStr PF.otherReadMode "r"
++ hasFmStr PF.otherWriteMode "w"
++ hasFmStr PF.otherExecuteMode "x"
hasFmStr fm str
| hasFM fm = str
| otherwise = "-"
hasFM fm = ffm `PF.intersectFileModes` fm == fm
packFileType :: File a -> String
packFileType file = case file of
Dir {} -> "Directory"
RegFile {} -> "Regular File"
SymLink {} -> "Symbolic Link"
BlockDev {} -> "Block Device"
CharDev {} -> "Char Device"
NamedPipe {} -> "Named Pipe"
Socket {} -> "Socket"
_ -> "Unknown"
packLinkDestination :: File a -> Maybe ByteString
packLinkDestination file = case file of
SymLink { rawdest = dest } -> Just dest
_ -> Nothing
---- OTHER: ----
-- |Apply a function on the free variable. If there is no free variable
-- for the given constructor the value from the `Default` class is used.
fromFreeVar :: (Default d) => (a -> d) -> File a -> d
fromFreeVar f df = maybeD f $ getFreeVar df
getFPasStr :: File a -> String
getFPasStr = toString . P.fromAbs . path
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: File a -> Maybe a
getFreeVar (Dir _ d) = Just d
getFreeVar (RegFile _ d) = Just d
getFreeVar (SymLink _ d _ _) = Just d
getFreeVar (BlockDev _ d) = Just d
getFreeVar (CharDev _ d) = Just d
getFreeVar (NamedPipe _ d) = Just d
getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing

84
src/HSFM/FileSystem/UtilTypes.hs
View File

@@ -1,84 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides high-level IO related file operations like
-- copy, delete, move and so on. It only operates on `Path Abs` which
-- guarantees us well-typed paths which are absolute.
--
-- Some functions are just path-safe wrappers around
-- unix functions, others have stricter exception handling
-- and some implement functionality that doesn't have a unix
-- counterpart (like `copyDirRecursive`).
--
-- Some of these operations are due to their nature not _atomic_, which
-- means they may do multiple syscalls which form one context. Some
-- of them also have to examine the filetypes explicitly before the
-- syscalls, so a reasonable decision can be made. That means
-- the result is undefined if another process changes that context
-- while the non-atomic operation is still happening. However, where
-- possible, as few syscalls as possible are used and the underlying
-- exception handling is kept.
module HSFM.FileSystem.UtilTypes where
import Data.ByteString
(
ByteString
)
import HPath
(
Path
, Abs
, Fn
)
-- |Data type describing file operations.
-- Useful to build up a list of operations or delay operations.
data FileOperation = FCopy Copy
| FMove Move
| FDelete [Path Abs]
| FOpen (Path Abs)
| FExecute (Path Abs) [ByteString]
| None
-- |Data type describing partial or complete file copy operation.
data Copy = PartialCopy [Path Abs] -- source files
| Copy [Path Abs] -- source files
(Path Abs) -- base destination directory
-- |Data type describing partial or complete file move operation.
data Move = PartialMove [Path Abs] -- source files
| Move [Path Abs] -- source files
(Path Abs) -- base destination directory
-- |Collision modes that describe the behavior in case a file collision
-- happens.
data FCollisonMode = Strict -- ^ fail if the target already exists
| Overwrite
| OverwriteAll
| Skip
| Rename (Path Fn)

80
src/HSFM/GUI/Glib/GlibString.hs
View File

@@ -1,80 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Glib.GlibString where
import qualified Data.ByteString as BS
import Data.ByteString.UTF8
(
toString
)
import Data.Word8
(
_percent
)
import Foreign.C.String
(
CStringLen
, CString
)
import Foreign.C.Types
(
CSize(..)
)
import Foreign.Marshal.Utils
(
maybePeek
)
import Foreign.Ptr
(
nullPtr
, plusPtr
)
import System.Glib.UTFString
-- TODO: move this to its own module
instance GlibString BS.ByteString where
withUTFString = BS.useAsCString
withUTFStringLen s f = BS.useAsCStringLen s (f . noNullPtrs)
peekUTFString s = do
len <- c_strlen s
BS.packCStringLen (s, fromIntegral len)
maybePeekUTFString = maybePeek peekUTFString
peekUTFStringLen = BS.packCStringLen
newUTFString = newUTFString . toString
newUTFStringLen = newUTFStringLen . toString
genUTFOfs = genUTFOfs . toString
stringLength = BS.length
unPrintf s = BS.intercalate "%%" (BS.split _percent s)
foreign import ccall unsafe "string.h strlen" c_strlen
:: CString -> IO CSize
noNullPtrs :: CStringLen -> CStringLen
noNullPtrs (p, 0) | p == nullPtr = (plusPtr p 1, 0)
noNullPtrs s = s

60
src/HSFM/GUI/Gtk.hs
View File

@@ -1,60 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module Main where
import Data.Maybe
(
fromJust
, fromMaybe
)
import Graphics.UI.Gtk
import qualified HPath as P
import HSFM.GUI.Gtk.Callbacks
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.MyGUI
import HSFM.GUI.Gtk.MyView
import Safe
(
headDef
)
import qualified System.Posix.Env.ByteString as SPE
main :: IO ()
main = do
_ <- initGUI
args <- SPE.getArgs
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
(P.parseAbs . headDef "/" $ args)
mygui <- createMyGUI
_ <- newTab mygui createTreeView mdir
setGUICallbacks mygui
widgetShowAll (rootWin mygui)
_ <- mainGUI
return ()

532
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@@ -1,532 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Callbacks where
import Control.Concurrent.STM
(
readTVarIO
)
import Control.Exception
(
throwIO
)
import Control.Monad
(
forM_
, void
, when
)
import Control.Monad.IO.Class
(
liftIO
)
import Data.ByteString
(
ByteString
)
import Data.ByteString.UTF8
(
fromString
, toString
)
import Data.Foldable
(
for_
)
import Graphics.UI.Gtk
import qualified HPath as P
import HPath
(
Abs
, Path
)
import HPath.IO
import HPath.IO.Errors
import HPath.IO.Utils
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Callbacks.Utils
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import Prelude hiding(readFile)
import System.Glib.UTFString
(
glibToString
)
import System.Posix.Env.ByteString
(
getEnv
)
import qualified System.Posix.Process.ByteString as SPP
import System.Posix.Types
(
ProcessID
)
-----------------
--[ Callbacks ]--
-----------------
---- MAIN CALLBACK ENTRYPOINT ----
-- |Set callbacks for the whole gui, on hotkeys, events and stuff.
setGUICallbacks :: MyGUI -> IO ()
setGUICallbacks mygui = do
_ <- clearStatusBar mygui `on` buttonActivated $ do
popStatusbar mygui
writeTVarIO (operationBuffer mygui) None
-- menubar-file
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
mainQuit
-- menubar-help
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
liftIO showAboutDialog
return ()
-- key events
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
return ()
-- |Set callbacks specific to a given view, on hotkeys, events and stuff.
setViewCallbacks :: MyGUI -> MyView -> IO ()
setViewCallbacks mygui myview = do
view' <- readTVarIO $ view myview
case view' of
fmv@(FMTreeView treeView) -> do
_ <- treeView `on` rowActivated
$ (\_ _ -> withItems mygui myview open)
-- drag events
_ <- treeView `on` dragBegin $
\_ -> withItems mygui myview moveInit
_ <- treeView `on` dragDrop $
\dc p ts -> do
p' <- treeViewConvertWidgetToTreeCoords treeView p
mpath <- treeViewGetPathAtPos treeView p'
case mpath of
Nothing -> do
dragFinish dc False False ts
return False
Just _ -> do
atom <- atomNew ("HSFM" :: String)
dragGetData treeView dc atom ts
return True
_ <- treeView `on` dragDataReceived $
\dc p _ ts ->
liftIO $ do
signalStopEmission treeView "drag_data_received"
p' <- treeViewConvertWidgetToTreeCoords treeView p
mpath <- treeViewGetPathAtPos treeView p'
case mpath of
Nothing -> dragFinish dc False False ts
Just (tp, _, _) -> do
mitem <- rawPathToItem myview tp
forM_ mitem $ \item ->
operationFinal mygui myview (Just item)
dragFinish dc True False ts
commonGuiEvents fmv
return ()
fmv@(FMIconView iconView) -> do
_ <- iconView `on` itemActivated
$ (\_ -> withItems mygui myview open)
commonGuiEvents fmv
return ()
where
commonGuiEvents fmv = do
let view = fmViewToContainer fmv
-- GUI events
_ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
_ <- upViewB myview `on` buttonActivated $
upDir mygui myview
_ <- homeViewB myview `on` buttonActivated $
goHome mygui myview
_ <- refreshViewB myview `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview
refreshView' mygui myview cdir
-- key events
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> refreshView' mygui myview cdir
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Left" <- fmap glibToString eventKeyName
liftIO $ goHistoryPrev mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Right" <- fmap glibToString eventKeyName
liftIO $ goHistoryNext mygui myview
_ <- view `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview del
_ <- view `on` keyPressEvent $ tryEvent $ do
[] <- eventModifier
"Return" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview open
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview copyInit
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"x" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview moveInit
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
liftIO $ operationFinal mygui myview Nothing
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"t" <- fmap glibToString eventKeyName
liftIO $ void $ do
cwd <- getCurrentDir myview
newTab mygui createTreeView (path cwd)
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"w" <- fmap glibToString eventKeyName
liftIO $ void $ closeTab mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
"F4" <- fmap glibToString eventKeyName
liftIO $ void $ openTerminalHere myview
-- righ-click
_ <- view `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
RightButton -> do
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
$ Just (RightButton, t)
-- this is just to not screw with current selection
-- on right-click
-- TODO: this misbehaves under IconView
(x, y) <- eventCoordinates
mpath <- liftIO $ getPathAtPos fmv (x, y)
case mpath of
-- item under the cursor, only pass on the signal
-- if the item under the cursor is not within the current
-- selection
(Just tp) -> do
selectedTps <- liftIO $ getSelectedTreePaths mygui myview
return $ elem tp selectedTps
-- no item under the cursor, pass on the signal
Nothing -> return False
OtherButton 8 -> do
liftIO $ goHistoryPrev mygui myview
return False
OtherButton 9 -> do
liftIO $ goHistoryNext mygui myview
return False
-- not right-click, so pass on the signal
_ -> return False
-- right click menu
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
liftIO $ newFile mygui myview
_ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
liftIO $ newDir mygui myview
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
liftIO $ operationFinal mygui myview Nothing
_ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview del
_ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview showFilePropertyDialog
_ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
_ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
return ()
getPathAtPos fmv (x, y) =
case fmv of
FMTreeView treeView -> do
mp <- treeViewGetPathAtPos treeView (round x, round y)
return $ fmap (\(p, _, _) -> p) mp
FMIconView iconView ->
fmap (\tp -> if null tp then Nothing else Just tp)
$ iconViewGetPathAtPos iconView (round x) (round y)
---- OTHER ----
openTerminalHere :: MyView -> IO ProcessID
openTerminalHere myview = do
cwd <- (P.fromAbs . path) <$> getCurrentDir myview
-- TODO: make terminal configurable
SPP.forkProcess $ SPP.executeFile "sakura" True ["-d", cwd] Nothing
---- TAB OPERATIONS ----
-- |Closes the current tab, but only if there is more than one tab.
closeTab :: MyGUI -> MyView -> IO ()
closeTab mygui myview = do
n <- notebookGetNPages (notebook mygui)
when (n > 1) $ void $ destroyView mygui myview
---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
del :: [Item] -> MyGUI -> MyView -> IO ()
del [item] _ _ = withErrorDialog $ do
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
withConfirmationDialog cmsg
$ easyDelete . path $ item
-- this throws on the first error that occurs
del items@(_:_) _ _ = withErrorDialog $ do
let cmsg = "Really delete " ++ show (length items) ++ " files?"
withConfirmationDialog cmsg
$ forM_ items $ \item -> easyDelete . path $ item
del _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
-- |Initializes a file move operation.
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
moveInit items@(_:_) mygui _ = do
writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
let sbmsg = case items of
(item:[]) -> "Move buffer: " ++ getFPasStr item
_ -> "Move buffer: " ++ (show . length $ items)
++ " items"
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
moveInit _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"No file selected!"
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
copyInit items@(_:_) mygui _ = do
writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
let sbmsg = case items of
(item:[]) -> "Copy buffer: " ++ getFPasStr item
_ -> "Copy buffer: " ++ (show . length $ items)
++ " items"
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
copyInit _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"No file selected!"
-- |Finalizes a file operation, such as copy or move.
operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
operationFinal mygui myview mitem = withErrorDialog $ do
op <- readTVarIO (operationBuffer mygui)
cdir <- case mitem of
Nothing -> path <$> getCurrentDir myview
Just x -> return $ path x
case op of
FMove (PartialMove s) -> do
let cmsg = "Really move " ++ imsg s
++ " to \"" ++ toString (P.fromAbs cdir)
++ "\"?"
withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
popStatusbar mygui
writeTVarIO (operationBuffer mygui) None
FCopy (PartialCopy s) -> do
let cmsg = "Really copy " ++ imsg s
++ " to \"" ++ toString (P.fromAbs cdir)
++ "\"?"
withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
_ -> return ()
where
imsg s = case s of
(item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\""
items -> (show . length $ items) ++ " items"
-- |Create a new file.
newFile :: MyGUI -> MyView -> IO ()
newFile _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name" ("" :: String)
let pmfn = P.parseFn =<< fromString <$> mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createRegularFile (path cdir P.</> fn)
-- |Create a new directory.
newDir :: MyGUI -> MyView -> IO ()
newDir _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter directory name" ("" :: String)
let pmfn = P.parseFn =<< fromString <$> mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createDir (path cdir P.</> fn)
renameF :: [Item] -> MyGUI -> MyView -> IO ()
renameF [item] _ _ = withErrorDialog $ do
iname <- P.fromRel <$> (P.basename $ path item)
mfn <- textInputDialog "Enter new file name" (iname :: ByteString)
let pmfn = P.parseFn =<< fromString <$> mfn
for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ getFPasStr item
++ "\"" ++ " to \""
++ toString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $
HPath.IO.renameFile (path item)
((P.dirname $ path item) P.</> fn)
renameF _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
---- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ----
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
--
-- If the url is invalid, does nothing.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar myview)
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp')
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
goHome :: MyGUI -> MyView -> IO ()
goHome mygui myview = withErrorDialog $ do
mhomedir <- getEnv "HOME"
forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp')
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
-- |Execute a given file.
execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] _ _ = withErrorDialog $
void $ executeFile (path item) []
execute _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
-- |Supposed to be used with 'withRows'. Opens a file or directory.
open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
DirOrSym r -> do
nv <- readFile getFileInfo $ path r
goDir mygui myview nv
r ->
void $ openFile . path $ r
-- this throws on the first error that occurs
open (FileLikeList fs) _ _ = withErrorDialog $
forM_ fs $ \f -> void $ openFile . path $ f
open _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
-- |Go up one directory and visualize it in the treeView.
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
nv <- goUp cdir
goDir mygui myview nv
-- |Go "back" in the history.
goHistoryPrev :: MyGUI -> MyView -> IO ()
goHistoryPrev mygui myview = do
hs <- readTVarIO (history myview)
case hs of
([], _) -> return ()
(x:xs, _) -> do
cdir <- getCurrentDir myview
nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(_, n) -> (xs, path cdir `addHistory` n))
refreshView' mygui myview nv
-- |Go "forth" in the history.
goHistoryNext :: MyGUI -> MyView -> IO ()
goHistoryNext mygui myview = do
hs <- readTVarIO (history myview)
case hs of
(_, []) -> return ()
(_, x:xs) -> do
cdir <- getCurrentDir myview
nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, xs))
refreshView' mygui myview nv

110
src/HSFM/GUI/Gtk/Callbacks/Utils.hs
View File

@@ -1,110 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Callbacks.Utils where
import Control.Monad
(
forM
, forM_
)
import Control.Monad.IO.Class
(
liftIO
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Graphics.UI.Gtk
import qualified HPath as P
import HPath.IO
import HPath.IO.Errors
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
(
modifyTVarIO
)
import Prelude hiding(readFile)
import Control.Concurrent.STM.TVar
(
readTVarIO
)
-- |Carries out a file operation with the appropriate error handling
-- allowing the user to react to various exceptions with further input.
doFileOperation :: FileOperation -> IO ()
doFileOperation (FCopy (Copy (f':fs') to)) =
_doFileOperation (f':fs') to easyCopyOverwrite easyCopy
$ doFileOperation (FCopy $ Copy fs' to)
doFileOperation (FMove (Move (f':fs') to)) =
_doFileOperation (f':fs') to moveFileOverwrite moveFile
$ doFileOperation (FMove $ Move fs' to)
doFileOperation _ = return ()
_doFileOperation :: [P.Path b1]
-> P.Path P.Abs
-> (P.Path b1 -> P.Path P.Abs -> IO b)
-> (P.Path b1 -> P.Path P.Abs -> IO a)
-> IO ()
-> IO ()
_doFileOperation [] _ _ _ _ = return ()
_doFileOperation (f:fs) to mcOverwrite mc rest = do
toname <- P.basename f
let topath = to P.</> toname
reactOnError (mc f topath >> rest)
[(AlreadyExists , collisionAction fileCollisionDialog topath)]
[(FileDoesExist{}, collisionAction fileCollisionDialog topath)
,(DirDoesExist{} , collisionAction fileCollisionDialog topath)
,(SameFile{} , collisionAction renameDialog topath)]
where
collisionAction diag topath = do
mcm <- diag . P.fromAbs $ topath
forM_ mcm $ \cm -> case cm of
Overwrite -> mcOverwrite f topath >> rest
OverwriteAll -> forM_ (f:fs) $ \x -> do
toname' <- P.basename x
mcOverwrite x (to P.</> toname')
Skip -> rest
Rename newn -> mc f (to P.</> newn) >> rest
_ -> return ()
-- |Helper that is invoked for any directory change operations.
goDir :: MyGUI -> MyView -> Item -> IO ()
goDir mygui myview item = do
cdir <- getCurrentDir myview
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, []))
refreshView' mygui myview item

150
src/HSFM/GUI/Gtk/Data.hs
View File

@@ -1,150 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Data where
import Control.Concurrent.MVar
(
MVar
)
import Control.Concurrent.STM
(
TVar
)
import Graphics.UI.Gtk hiding (MenuBar)
import HPath
(
Abs
, Path
)
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import System.INotify
(
INotify
)
------------------
--[ Base Types ]--
------------------
-- |Monolithic object passed to various GUI functions in order
-- to keep the API stable and not alter the parameters too much.
-- This only holds GUI widgets that are needed to be read during
-- runtime.
data MyGUI = MkMyGUI {
-- |main Window
rootWin :: !Window
-- widgets on the main window
, menubar :: !MenuBar
, statusBar :: !Statusbar
, clearStatusBar :: !Button
, notebook :: !Notebook
-- other
, fprop :: !FilePropertyGrid
, settings :: !(TVar FMSettings)
, operationBuffer :: !(TVar FileOperation)
}
-- |This describes the contents of the current view and is separated from MyGUI,
-- because we might want to have multiple views.
data MyView = MkMyView {
view :: !(TVar FMView)
, cwd :: !(MVar Item)
, rawModel :: !(TVar (ListStore Item))
, sortedModel :: !(TVar (TypedTreeModelSort Item))
, filteredModel :: !(TVar (TypedTreeModelFilter Item))
, inotify :: !(MVar INotify)
-- the first part of the tuple represents the "go back"
-- the second part the "go forth" in the history
, history :: !(TVar ([Path Abs], [Path Abs]))
-- sub-widgets
, scroll :: !ScrolledWindow
, viewBox :: !Box
, rcmenu :: !RightClickMenu
, upViewB :: !Button
, homeViewB :: !Button
, refreshViewB :: !Button
, urlBar :: !Entry
}
data MenuBar = MkMenuBar {
menubarFileQuit :: !ImageMenuItem
, menubarHelpAbout :: !ImageMenuItem
}
data RightClickMenu = MkRightClickMenu {
rcMenu :: !Menu
, rcFileOpen :: !ImageMenuItem
, rcFileExecute :: !ImageMenuItem
, rcFileNewRegFile :: !ImageMenuItem
, rcFileNewDir :: !ImageMenuItem
, rcFileCut :: !ImageMenuItem
, rcFileCopy :: !ImageMenuItem
, rcFileRename :: !ImageMenuItem
, rcFilePaste :: !ImageMenuItem
, rcFileDelete :: !ImageMenuItem
, rcFileProperty :: !ImageMenuItem
, rcFileIconView :: !ImageMenuItem
, rcFileTreeView :: !ImageMenuItem
}
data FilePropertyGrid = MkFilePropertyGrid {
fpropGrid :: !Grid
, fpropFnEntry :: !Entry
, fpropLocEntry :: !Entry
, fpropTsEntry :: !Entry
, fpropModEntry :: !Entry
, fpropAcEntry :: !Entry
, fpropFTEntry :: !Entry
, fpropPermEntry :: !Entry
, fpropLDEntry :: !Entry
}
-- |FM-wide settings.
data FMSettings = MkFMSettings {
showHidden :: !Bool
, isLazy :: !Bool
, iconSize :: !Int
}
data FMView = FMTreeView !TreeView
| FMIconView !IconView
type Item = File FileInfo
fmViewToContainer :: FMView -> Container
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x

306
src/HSFM/GUI/Gtk/Dialogs.hs
View File

@@ -1,306 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Dialogs where
import Control.Applicative
(
(<$>)
)
import Control.Exception
(
displayException
, throwIO
, IOException
, catches
, Handler(..)
)
import Control.Monad
(
forM
, when
, void
)
import Data.ByteString
(
ByteString
)
import qualified Data.ByteString as BS
import Data.ByteString.UTF8
(
fromString
)
import Data.Version
(
showVersion
)
import Distribution.Package
(
PackageIdentifier(..)
, PackageName(..)
)
import Distribution.PackageDescription
(
GenericPackageDescription(..)
, PackageDescription(..)
)
import Distribution.PackageDescription.Parse
(
readPackageDescription
)
import Distribution.Verbosity
(
silent
)
import Graphics.UI.Gtk
import qualified HPath as P
import HPath.IO.Errors
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Errors
import Paths_hsfm
(
getDataFileName
)
import System.Glib.UTFString
(
GlibString
)
import System.Posix.FilePath
(
takeFileName
)
---------------------
--[ Dialog popups ]--
---------------------
-- |Pops up an error Dialog with the given String.
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
-- |Asks the user for confirmation and returns True/False.
showConfirmationDialog :: String -> IO Bool
showConfirmationDialog str = do
confirmDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsYesNo
str
rID <- dialogRun confirmDialog
widgetDestroy confirmDialog
case rID of
ResponseYes -> return True
ResponseNo -> return False
_ -> return False
fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
fileCollisionDialog t = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
(fromString "Target \"" `BS.append`
t `BS.append`
fromString "\" exists, how to proceed?")
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Overwrite" (ResponseUser 1)
_ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 3)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 4)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Nothing
ResponseUser 1 -> return (Just Overwrite)
ResponseUser 2 -> return (Just OverwriteAll)
ResponseUser 3 -> return (Just Skip)
ResponseUser 4 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do
pfn <- P.parseFn (fromString fn)
return $ Rename pfn
_ -> throwIO UnknownDialogButton
renameDialog :: ByteString -> IO (Maybe FCollisonMode)
renameDialog t = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
(fromString "Target \"" `BS.append`
t `BS.append`
fromString "\" exists, how to proceed?")
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 1)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 2)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Nothing
ResponseUser 1 -> return (Just Skip)
ResponseUser 2 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do
pfn <- P.parseFn (fromString fn)
return $ Rename pfn
_ -> throwIO UnknownDialogButton
-- |Shows the about dialog from the help menu.
showAboutDialog :: IO ()
showAboutDialog = do
ad <- aboutDialogNew
lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
pdesc <- fmap packageDescription
(readPackageDescription silent
=<< getDataFileName "hsfm.cabal")
set ad
[ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc
, aboutDialogName := (unPackageName . pkgName . package) pdesc
, aboutDialogVersion := (showVersion . pkgVersion . package) pdesc
, aboutDialogCopyright := copyright pdesc
, aboutDialogComments := description pdesc
, aboutDialogLicense := Just lstr
, aboutDialogWebsite := homepage pdesc
, aboutDialogAuthors := [author pdesc]
, aboutDialogLogo := Just hsfmicon
, aboutDialogWrapLicense := True
]
_ <- dialogRun ad
widgetDestroy ad
-- |Carry out an IO action with a confirmation dialog.
-- If the user presses "No", then do nothing.
withConfirmationDialog :: String -> IO () -> IO ()
withConfirmationDialog str io = do
run <- showConfirmationDialog str
when run io
-- |Execute the given IO action. If the action throws exceptions,
-- visualize them via 'showErrorDialog'.
withErrorDialog :: IO a -> IO ()
withErrorDialog io =
catches (void io)
[ Handler (\e -> showErrorDialog
$ displayException (e :: IOException))
, Handler (\e -> showErrorDialog
$ displayException (e :: HPathIOException))
]
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
textInputDialog :: GlibString string
=> string -- ^ window title
-> string -- ^ initial text in input widget
-> IO (Maybe String)
textInputDialog title inittext = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
title
entry <- entryNew
entrySetText entry inittext
cbox <- dialogGetActionArea chooserDialog
_ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) entry PackNatural 5
widgetShowAll chooserDialog
rID <- dialogRun chooserDialog
ret <- case rID of
-- TODO: make this more safe
ResponseUser 0 -> Just <$> entryGetText entry
ResponseUser 1 -> return Nothing
_ -> throwIO UnknownDialogButton
widgetDestroy chooserDialog
return ret
showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
showFilePropertyDialog [item] mygui _ = do
dialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageInfo
ButtonsNone
"File Properties"
let fprop' = fprop mygui
grid = fpropGrid fprop'
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
$ P.basename . path $ item)
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
entrySetText (fpropModEntry fprop') (packModTime item)
entrySetText (fpropAcEntry fprop') (packAccessTime item)
entrySetText (fpropFTEntry fprop') (packFileType item)
entrySetText (fpropPermEntry fprop')
(tail $ packPermissions item) -- throw away the filetype part
case packLinkDestination item of
(Just dest) -> do
widgetSetSensitive (fpropLDEntry fprop') True
entrySetText (fpropLDEntry fprop') dest
Nothing -> do
widgetSetSensitive (fpropLDEntry fprop') False
entrySetText (fpropLDEntry fprop') "( Not a symlink )"
cbox <- dialogGetActionArea dialog
_ <- dialogAddButton dialog "Ok" (ResponseUser 0)
_ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) grid PackNatural 5
widgetShowAll dialog
_ <- dialogRun dialog
-- make sure our grid does not get destroyed
containerRemove (castToBox cbox) grid
widgetDestroy dialog
return ()
showFilePropertyDialog _ _ _ = return ()

35
src/HSFM/GUI/Gtk/Errors.hs
View File

@@ -1,35 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |Provides error handling for Gtk.
module HSFM.GUI.Gtk.Errors where
import Control.Exception
import Data.Typeable
data GtkException = UnknownDialogButton
deriving (Show, Typeable)
instance Exception GtkException

97
src/HSFM/GUI/Gtk/MyGUI.hs
View File

@@ -1,97 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.MyGUI where
import Control.Concurrent.STM
(
newTVarIO
)
import Graphics.UI.Gtk
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Data
import Paths_hsfm
(
getDataFileName
)
-------------------------
--[ Main Window Setup ]--
-------------------------
-- |Set up the GUI. This only creates the permanent widgets.
createMyGUI :: IO MyGUI
createMyGUI = do
let settings' = MkFMSettings False True 24
settings <- newTVarIO settings'
operationBuffer <- newTVarIO None
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-- get the pre-defined gui widgets
rootWin <- builderGetObject builder castToWindow
"rootWin"
menubarFileQuit <- builderGetObject builder castToImageMenuItem
"menubarFileQuit"
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
"menubarHelpAbout"
statusBar <- builderGetObject builder castToStatusbar
"statusBar"
clearStatusBar <- builderGetObject builder castToButton
"clearStatusBar"
fpropGrid <- builderGetObject builder castToGrid
"fpropGrid"
fpropFnEntry <- builderGetObject builder castToEntry
"fpropFnEntry"
fpropLocEntry <- builderGetObject builder castToEntry
"fpropLocEntry"
fpropTsEntry <- builderGetObject builder castToEntry
"fpropTsEntry"
fpropModEntry <- builderGetObject builder castToEntry
"fpropModEntry"
fpropAcEntry <- builderGetObject builder castToEntry
"fpropAcEntry"
fpropFTEntry <- builderGetObject builder castToEntry
"fpropFTEntry"
fpropPermEntry <- builderGetObject builder castToEntry
"fpropPermEntry"
fpropLDEntry <- builderGetObject builder castToEntry
"fpropLDEntry"
notebook <- builderGetObject builder castToNotebook
"notebook"
-- construct the gui object
let menubar = MkMenuBar {..}
let fprop = MkFilePropertyGrid {..}
let mygui = MkMyGUI {..}
-- sets the default icon
_ <- windowSetDefaultIconFromFile
=<< getDataFileName "data/Gtk/icons/hsfm.png"
return mygui

460
src/HSFM/GUI/Gtk/MyView.hs
View File

@@ -1,460 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
module HSFM.GUI.Gtk.MyView where
import Control.Applicative
(
(<$>)
)
import Control.Concurrent.MVar
(
newEmptyMVar
, putMVar
, tryTakeMVar
)
import Control.Concurrent.STM
(
newTVarIO
, readTVarIO
)
import Control.Exception
(
try
, SomeException
)
import Control.Monad
(
forM_
)
import qualified Data.ByteString as BS
import Data.Foldable
(
for_
)
import Data.Maybe
(
catMaybes
, fromJust
)
import HPath.IO.Errors
(
canOpenDirectory
)
import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
import HPath
(
Path
, Abs
)
import qualified HPath as P
import HSFM.FileSystem.FileType
import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import Paths_hsfm
(
getDataFileName
)
import Prelude hiding(readFile)
import System.INotify
(
addWatch
, initINotify
, killINotify
, EventVariety(..)
)
import System.Posix.FilePath
(
pathSeparator
, hiddenFile
)
-- |Creates a new tab with its own view and refreshes the view.
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
newTab mygui iofmv path = do
myview <- createMyView mygui iofmv
i <- notebookAppendPage (notebook mygui) (viewBox myview)
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
mpage <- notebookGetNthPage (notebook mygui) i
forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
page
True
refreshView mygui myview (Just path)
return myview
-- |Constructs the initial MyView object with a few dummy models.
-- It also initializes the callbacks.
createMyView :: MyGUI
-> IO FMView
-> IO MyView
createMyView mygui iofmv = do
inotify <- newEmptyMVar
history <- newTVarIO ([],[])
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-- create dummy models, so we don't have to use MVar
rawModel <- newTVarIO =<< listStoreNew []
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
=<< readTVarIO rawModel
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
=<< readTVarIO filteredModel
cwd <- newEmptyMVar
view' <- iofmv
view <- newTVarIO view'
urlBar <- builderGetObject builder castToEntry
"urlBar"
rcMenu <- builderGetObject builder castToMenu
"rcMenu"
rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
"rcFileNewRegFile"
rcFileNewDir <- builderGetObject builder castToImageMenuItem
"rcFileNewDir"
rcFileCut <- builderGetObject builder castToImageMenuItem
"rcFileCut"
rcFileCopy <- builderGetObject builder castToImageMenuItem
"rcFileCopy"
rcFileRename <- builderGetObject builder castToImageMenuItem
"rcFileRename"
rcFilePaste <- builderGetObject builder castToImageMenuItem
"rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete"
rcFileProperty <- builderGetObject builder castToImageMenuItem
"rcFileProperty"
rcFileIconView <- builderGetObject builder castToImageMenuItem
"rcFileIconView"
rcFileTreeView <- builderGetObject builder castToImageMenuItem
"rcFileTreeView"
upViewB <- builderGetObject builder castToButton
"upViewB"
homeViewB <- builderGetObject builder castToButton
"homeViewB"
refreshViewB <- builderGetObject builder castToButton
"refreshViewB"
scroll <- builderGetObject builder castToScrolledWindow
"mainScroll"
viewBox <- builderGetObject builder castToBox
"viewBox"
let rcmenu = MkRightClickMenu {..}
let myview = MkMyView {..}
-- set the bindings
setViewCallbacks mygui myview
-- add the treeview to the scroll container
let oview = fmViewToContainer view'
containerAdd scroll oview
widgetShowAll viewBox
return myview
-- |Switch the existing view in `MyView` with the one that the
-- io action returns.
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
switchView mygui myview iofmv = do
cwd <- getCurrentDir myview
oldpage <- destroyView mygui myview
-- create new view and tab page where the previous one was
nview <- createMyView mygui iofmv
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
(maybe (P.fromAbs $ path cwd) P.fromRel
$ P.basename . path $ cwd) oldpage
notebookSetCurrentPage (notebook mygui) newpage
refreshView' mygui nview cwd
-- |Destroys the current view by disconnecting the watcher
-- and destroying the active FMView container.
--
-- Everything that needs to be done in order to forget about a
-- view needs to be done here.
--
-- Returns the page in the tab list this view corresponds to.
destroyView :: MyGUI -> MyView -> IO Int
destroyView mygui myview = do
-- disconnect watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
page <- notebookGetCurrentPage (notebook mygui)
-- destroy old view and tab page
view' <- readTVarIO $ view myview
widgetDestroy (fmViewToContainer view')
notebookRemovePage (notebook mygui) page
return page
-- |Createss an IconView.
createIconView :: IO FMView
createIconView = do
iconv <- iconViewNew
iconViewSetSelectionMode iconv SelectionMultiple
iconViewSetColumns iconv (-1)
iconViewSetSpacing iconv 2
iconViewSetMargin iconv 0
{- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
{- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
return $ FMIconView iconv
-- |Creates a TreeView.
createTreeView :: IO FMView
createTreeView = do
-- create the final view
treeView <- treeViewNew
-- set selection mode
tvs <- treeViewGetSelection treeView
treeSelectionSetMode tvs SelectionMultiple
-- set drag and drop
tl <- targetListNew
atom <- atomNew ("HSFM" :: String)
targetListAdd tl atom [TargetSameApp] 0
treeViewEnableModelDragDest treeView tl [ActionCopy]
treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy]
-- create final tree model columns
renderTxt <- cellRendererTextNew
renderPix <- cellRendererPixbufNew
let ct = cellText :: (CellRendererTextClass cr) => Attr cr String
cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
-- filename column
cF <- treeViewColumnNew
treeViewColumnSetTitle cF ("Filename" :: String)
treeViewColumnSetResizable cF True
treeViewColumnSetClickable cF True
treeViewColumnSetSortColumnId cF 1
cellLayoutPackStart cF renderPix False
cellLayoutPackStart cF renderTxt True
_ <- treeViewAppendColumn treeView cF
cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
-- date column
cMD <- treeViewColumnNew
treeViewColumnSetTitle cMD ("Date" :: String)
treeViewColumnSetResizable cMD True
treeViewColumnSetClickable cMD True
treeViewColumnSetSortColumnId cMD 2
cellLayoutPackStart cMD renderTxt True
_ <- treeViewAppendColumn treeView cMD
cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
-- permissions column
cP <- treeViewColumnNew
treeViewColumnSetTitle cP ("Permission" :: String)
treeViewColumnSetResizable cP True
treeViewColumnSetClickable cP True
treeViewColumnSetSortColumnId cP 3
cellLayoutPackStart cP renderTxt True
_ <- treeViewAppendColumn treeView cP
cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
return $ FMTreeView treeView
-- |Re-reads the current directory or the given one and updates the View.
-- This is more or less a wrapper around `refreshView'`
--
-- If the third argument is Nothing, it tries to re-read the current directory.
-- If that fails, it reads "/" instead.
--
-- If the third argument is (Just path) it tries to read "path". If that
-- fails, it reads "/" instead.
refreshView :: MyGUI
-> MyView
-> Maybe (Path Abs)
-> IO ()
refreshView mygui myview mfp =
case mfp of
Just fp -> do
canopen <- canOpenDirectory fp
if canopen
then refreshView' mygui myview =<< readFile getFileInfo fp
else refreshView mygui myview =<< getAlternativeDir
Nothing -> refreshView mygui myview =<< getAlternativeDir
where
getAlternativeDir = do
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
Item)
case ecd of
Right dir -> return (Just $ path dir)
Left _ -> return (P.parseAbs $ BS.singleton pathSeparator)
-- |Refreshes the View based on the given directory.
--
-- If the directory is not a Dir or a Symlink pointing to a Dir, then
-- calls `refreshView` with the 3rd argument being Nothing.
refreshView' :: MyGUI
-> MyView
-> Item
-> IO ()
refreshView' mygui myview SymLink { sdest = d@Dir{} } =
refreshView' mygui myview d
refreshView' mygui myview item@Dir{} = do
newRawModel <- fileListStore item myview
writeTVarIO (rawModel myview) newRawModel
view' <- readTVarIO $ view myview
_ <- tryTakeMVar (cwd myview)
putMVar (cwd myview) item
-- get selected items
tps <- getSelectedTreePaths mygui myview
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
constructView mygui myview
-- set notebook tab label
page <- notebookGetCurrentPage (notebook mygui)
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
notebookSetTabLabelText (notebook mygui) child
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
-- reselect selected items
-- TODO: not implemented for icon view yet
case view' of
FMTreeView treeView -> do
tvs <- treeViewGetSelection treeView
ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return ()
refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
refreshView' _ _ _ = return ()
-- |Constructs the visible View with the current underlying mutable models,
-- which are retrieved from 'MyGUI'.
--
-- This sort of merges the components mygui and myview and fires up
-- the actual models.
constructView :: MyGUI
-> MyView
-> IO ()
constructView mygui myview = do
settings' <- readTVarIO $ settings mygui
-- pix stuff
iT <- iconThemeGetDefault
folderPix <- getIcon IFolder iT (iconSize settings')
folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
filePix <- getIcon IFile iT (iconSize settings')
fileSymPix <- getSymlinkIcon IFile iT (iconSize settings')
errorPix <- getIcon IError iT (iconSize settings')
let dirtreePix Dir{} = folderPix
dirtreePix FileLike{} = filePix
dirtreePix DirSym{} = folderSymPix
dirtreePix FileLikeSym{} = fileSymPix
dirtreePix Failed{} = errorPix
dirtreePix BrokenSymlink{} = errorPix
dirtreePix _ = errorPix
view' <- readTVarIO $ view myview
cdirp <- path <$> getCurrentDir myview
-- update urlBar
entrySetText (urlBar myview) (P.fromAbs cdirp)
rawModel' <- readTVarIO $ rawModel myview
-- filtering
filteredModel' <- treeModelFilterNew rawModel' []
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
if hidden
then return True
else return . not . hiddenFile . P.fromRel $ item
-- sorting
sortedModel' <- treeModelSortNewWithModel filteredModel'
writeTVarIO (sortedModel myview) sortedModel'
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
item1 <- treeModelGetRow rawModel' cIter1
item2 <- treeModelGetRow rawModel' cIter2
return $ compare item1 item2
treeSortableSetSortColumnId sortedModel' 1 SortAscending
-- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
dirtreePix
treeModelSetColumn rawModel' (makeColumnIdString 1)
(P.toFilePath . fromJust . P.basename . path)
treeModelSetColumn rawModel' (makeColumnIdString 2)
packModTime
treeModelSetColumn rawModel' (makeColumnIdString 3)
packPermissions
-- update model of view
case view' of
FMTreeView treeView -> do
treeViewSetModel treeView sortedModel'
treeViewSetRubberBanding treeView True
FMIconView iconView -> do
iconViewSetModel iconView (Just sortedModel')
iconViewSetPixbufColumn iconView
(makeColumnIdPixbuf 0 :: ColumnId item Pixbuf)
iconViewSetTextColumn iconView
(makeColumnIdString 1 :: ColumnId item String)
-- add watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
newi <- initINotify
_ <- addWatch
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
(P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
putMVar (inotify myview) newi
return ()

170
src/HSFM/GUI/Gtk/Utils.hs
View File

@@ -1,170 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Utils where
import Control.Applicative
(
(<$>)
)
import Control.Concurrent.MVar
(
readMVar
)
import Control.Concurrent.STM
(
readTVarIO
)
import Data.Maybe
(
catMaybes
, fromJust
)
import Data.Traversable
(
forM
)
import Graphics.UI.Gtk
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data
import Prelude hiding(getContents)
-----------------
--[ Utilities ]--
-----------------
getSelectedTreePaths :: MyGUI -> MyView -> IO [TreePath]
getSelectedTreePaths _ myview = do
view' <- readTVarIO $ view myview
case view' of
FMTreeView treeView -> do
tvs <- treeViewGetSelection treeView
treeSelectionGetSelectedRows tvs
FMIconView iconView ->
iconViewGetSelectedItems iconView
-- |Gets the currently selected item of the treeView, if any.
getSelectedItems :: MyGUI
-> MyView
-> IO [Item]
getSelectedItems mygui myview = do
tps <- getSelectedTreePaths mygui myview
catMaybes <$> mapM (rawPathToItem myview) tps
-- |Carry out an action on the currently selected item.
--
-- If there is no item selected, does nothing.
withItems :: MyGUI
-> MyView
-> ( [Item]
-> MyGUI
-> MyView
-> IO ()) -- ^ action to carry out
-> IO ()
withItems mygui myview io = do
items <- getSelectedItems mygui myview
io items mygui myview
-- |Create the 'ListStore' of files/directories from the current directory.
-- This is the function which maps the Data.DirTree data structures
-- into the GTK+ data structures.
fileListStore :: Item -- ^ current dir
-> MyView
-> IO (ListStore Item)
fileListStore dt _ = do
cs <- getContents getFileInfo dt
listStoreNew cs
-- |Currently unsafe. This is used to obtain any item, which will
-- fail if there is none.
getFirstItem :: MyView
-> IO Item
getFirstItem myview = do
rawModel' <- readTVarIO $ rawModel myview
iter <- fromJust <$> treeModelGetIterFirst rawModel'
treeModelGetRow rawModel' iter
-- |Reads the current directory from MyView.
--
-- This reads the MVar and may block the main thread if it's
-- empty.
getCurrentDir :: MyView
-> IO Item
getCurrentDir myview = readMVar (cwd myview)
-- |Push a message to the status bar.
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
pushStatusBar mygui str = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
mid <- statusbarPush sb cid str
return (cid, mid)
-- |Pop a message from the status bar.
popStatusbar :: MyGUI -> IO ()
popStatusbar mygui = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
statusbarPop sb cid
-- |Turn a path on the rawModel into a path that we can
-- use at the outermost model layer.
rawPathToIter :: MyView -> TreePath -> IO (Maybe TreeIter)
rawPathToIter myview tp = do
fmodel <- readTVarIO (filteredModel myview)
smodel <- readTVarIO (sortedModel myview)
msiter <- treeModelGetIter smodel tp
forM msiter $ \siter -> do
cIter <- treeModelSortConvertIterToChildIter smodel siter
treeModelFilterConvertIterToChildIter fmodel cIter
-- |Turn a path on the rawModel into the corresponding item
-- that we can use at the outermost model layer.
rawPathToItem :: MyView -> TreePath -> IO (Maybe Item)
rawPathToItem myview tp = do
rawModel' <- readTVarIO $ rawModel myview
miter <- rawPathToIter myview tp
forM miter $ \iter -> treeModelGetRow rawModel' iter
-- |Makes sure the list is max 5. This is probably not very efficient
-- but we don't care, since it's a small list anyway.
addHistory :: Eq a => a -> [a] -> [a]
addHistory i [] = [i]
addHistory i xs@(x:_)
| i == x = xs
| length xs == maxLength = i : take (maxLength - 1) xs
| otherwise = i : xs
where
maxLength = 10

36
src/HSFM/Utils/MyPrelude.hs
View File

@@ -1,36 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
module HSFM.Utils.MyPrelude where
import Data.Default
import Data.List
-- |Turns any list into a list of the same length with the values
-- being the indices.
-- E.g.: "abdasd" -> [0,1,2,3,4,5]
listIndices :: [a] -> [Int]
listIndices = findIndices (const True)
-- |A `maybe` flavor using the `Default` class.
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
maybeD = maybe def

127
src/IO/Error.hs Normal file
View File

@@ -0,0 +1,127 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- |Provides error handling.
module IO.Error where
import Control.Applicative
(
(<$>)
)
import Control.Exception
import Control.Monad
(
unless
, void
, when
)
import Data.List
(
isPrefixOf
)
import Data.Typeable
import IO.Utils
import System.Directory
(
doesDirectoryExist
, doesFileExist
)
import System.FilePath
(
equalFilePath
, isAbsolute
, takeFileName
)
import qualified System.Posix.Files as PF
data FmIOException = FileDoesNotExist String
| DirDoesNotExist String
| PathNotAbsolute String
| FileNotExecutable String
| SameFile String String
| NotAFile String
| NotADir String
| DestinationInSource String String
| FileDoesExist String
| DirDoesExist String
| IsSymlink String
deriving (Show, Typeable)
instance Exception FmIOException
-- Throws an exception if the filepath is not absolute
-- or the file does not exist.
fileSanityThrow :: FilePath -> IO ()
fileSanityThrow fp = throwNotAbsolute fp >> throwFileDoesNotExist fp
-- Throws an exception if the filepath is not absolute
-- or the dir does not exist.
dirSanityThrow :: FilePath -> IO ()
dirSanityThrow fp = throwNotAbsolute fp >> throwDirDoesNotExist fp
throwNotAbsolute :: FilePath -> IO ()
throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
throwFileDoesExist :: FilePath -> IO ()
throwFileDoesExist fp =
whenM (doesFileExist fp) (throw $ FileDoesExist fp)
throwDirDoesExist :: FilePath -> IO ()
throwDirDoesExist fp =
whenM (doesDirectoryExist fp) (throw $ DirDoesExist fp)
throwDirDoesNotExist :: FilePath -> IO ()
throwDirDoesNotExist fp =
unlessM (doesDirectoryExist fp) (throw $ DirDoesNotExist fp)
throwFileDoesNotExist :: FilePath -> IO ()
throwFileDoesNotExist fp =
unlessM (doesFileExist fp) (throw $ FileDoesNotExist fp)
throwSameFile :: FilePath -- ^ should be canonicalized
-> FilePath -- ^ should be canonicalized
-> IO ()
throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2)
throwDestinationInSource :: FilePath -- ^ should be canonicalized
-> FilePath -- ^ should be canonicalized
-> IO ()
throwDestinationInSource source dest =
when (source `isPrefixOf` dest) (throw $ DestinationInSource dest source)
throwIsSymlink :: FilePath -> IO ()
throwIsSymlink fp =
whenM (PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp)
(throw $ IsSymlink fp)

443
src/IO/File.hs Normal file
View File

@@ -0,0 +1,443 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides all the atomic IO related file operations like
-- copy, delete, move and so on. It operates only on FilePaths and reads
-- all necessary file information manually in order to stay atomic and not
-- rely on the state of passed objects.
--
-- It would be nicer to pass states around, but the filesystem state changes
-- too quickly and cannot be relied upon. Lazy implementations of filesystem
-- trees have been tried as well, but they can introduce subtle bugs.
module IO.File where
import Control.Applicative
(
(<$>)
)
import Control.Exception
(
handle
, throw
, SomeException(..)
)
import Control.Monad
(
unless
, void
)
import Data.DirTree
import Data.Foldable
(
for_
)
import IO.Error
import IO.Utils
import System.Directory
(
doesDirectoryExist
, doesFileExist
, removeDirectoryRecursive
)
import System.FilePath
(
equalFilePath
, isAbsolute
, takeFileName
, takeDirectory
, (</>)
)
import System.Posix.Directory
(
createDirectory
, removeDirectory
)
import System.Posix.Files
(
createSymbolicLink
, readSymbolicLink
, fileAccess
, getFileStatus
, groupExecuteMode
, groupReadMode
, groupWriteMode
, otherExecuteMode
, otherReadMode
, otherWriteMode
, ownerModes
, ownerReadMode
, ownerWriteMode
, rename
, touchFile
, unionFileModes
, removeLink
)
import System.Posix.IO
(
closeFd
, createFile
)
import System.Posix.Types
(
FileMode
)
import System.Process
(
spawnProcess
, ProcessHandle
)
import qualified System.Directory as SD
import qualified System.Posix.Files as PF
-- TODO: file operations should be threaded and not block the UI
-- |Data type describing an actual file operation that can be
-- carried out via `doFile`. Useful to build up a list of operations
-- or delay operations.
data FileOperation = FCopy Copy
| FMove Move
| FDelete (AnchoredFile FileInfo)
| FOpen (AnchoredFile FileInfo)
| FExecute (AnchoredFile FileInfo) [String]
| None
-- |Data type describing partial or complete file copy operation.
-- CC stands for a complete operation and can be used for `runFileOp`.
data Copy = CP1 (AnchoredFile FileInfo)
| CP2 (AnchoredFile FileInfo)
(AnchoredFile FileInfo)
| CC (AnchoredFile FileInfo)
(AnchoredFile FileInfo)
DirCopyMode
-- |Data type describing partial or complete file move operation.
-- MC stands for a complete operation and can be used for `runFileOp`.
data Move = MP1 (AnchoredFile FileInfo)
| MC (AnchoredFile FileInfo)
(AnchoredFile FileInfo)
-- |Directory copy modes.
data DirCopyMode = Strict -- ^ fail if the target directory already exists
| Merge -- ^ overwrite files if necessary
| Replace -- ^ remove target directory before copying
-- |Run a given FileOperation. If the FileOperation is partial, it will
-- be returned.
runFileOp :: FileOperation -> IO (Maybe FileOperation)
runFileOp (FCopy (CC from to cm)) = easyCopy cm from to >> return Nothing
runFileOp (FCopy fo) = return $ Just $ FCopy fo
runFileOp (FMove (MC from to)) = moveFile from to >> return Nothing
runFileOp (FMove fo) = return $ Just $ FMove fo
runFileOp (FDelete fp) = easyDelete fp >> return Nothing
runFileOp (FOpen fp) = openFile fp >> return Nothing
runFileOp (FExecute fp args) = executeFile fp args >> return Nothing
runFileOp _ = return Nothing
--------------------
--[ File Copying ]--
--------------------
-- TODO: allow renaming
-- |Copies a directory to the given destination with the specified
-- `DirCopyMode`. Excludes symlinks.
copyDir :: DirCopyMode
-> AnchoredFile FileInfo -- ^ source dir
-> AnchoredFile FileInfo -- ^ destination dir
-> IO ()
copyDir cm (_ :/ SymLink {}) _ = return ()
copyDir cm from@(_ :/ Dir fromn _)
to@(_ :/ Dir {})
= do
let fromp = fullPath from
top = fullPath to
destdirp = top </> fromn
throwDestinationInSource fromp destdirp
throwSameFile fromp destdirp
createDestdir destdirp
destdir <- Data.DirTree.readFile destdirp
contents <- readDirectory' (fullPath from)
for_ contents $ \f ->
case f of
(_ :/ SymLink {}) -> recreateSymlink f destdir
(_ :/ Dir {}) -> copyDir cm f destdir
(_ :/ RegFile {}) -> copyFileToDir f destdir
_ -> return ()
where
createDestdir destdir =
case cm of
Merge ->
unlessM (doesDirectoryExist destdir)
(createDirectory destdir newDirPerms)
Strict -> do
throwDirDoesExist destdir
createDirectory destdir newDirPerms
Replace -> do
whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir)
createDirectory destdir newDirPerms
recreateSymlink' f destdir = do
let destfilep = fullPath destdir </> (name . file $ f)
destfile <- Data.DirTree.readFile destfilep
_ <- case cm of
-- delete old file/dir to be able to create symlink
Merge -> easyDelete destfile
_ -> return ()
recreateSymlink f destdir
copyDir _ _ _ = return ()
-- |Recreate a symlink.
recreateSymlink :: AnchoredFile FileInfo -- ^ the old symlink file
-> AnchoredFile FileInfo -- ^ destination dir of the
-- new symlink file
-> IO ()
recreateSymlink symf@(_ :/ SymLink {})
symdest@(_ :/ Dir {})
= do
symname <- readSymbolicLink (fullPath symf)
createSymbolicLink symname (fullPath symdest </> (name . file $ symf))
recreateSymlink _ _ = return ()
-- |Copies the given file to the given file destination.
-- Excludes symlinks.
copyFile :: AnchoredFile FileInfo -- ^ source file
-> AnchoredFile FileInfo -- ^ destination file
-> IO ()
copyFile (_ :/ SymLink {}) _ = return ()
copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do
let from' = fullPath from
to' = fullPath to
throwSameFile from' to'
SD.copyFile from' to'
copyFile _ _ = return ()
-- |Copies the given file to the given dir with the same filename.
-- Excludes symlinks.
copyFileToDir :: AnchoredFile FileInfo
-> AnchoredFile FileInfo
-> IO ()
copyFileToDir (_ :/ SymLink {}) _ = return ()
copyFileToDir from@(_ :/ RegFile fn _)
to@(_ :/ Dir {}) =
do
let from' = fullPath from
to' = fullPath to </> fn
SD.copyFile from' to'
copyFileToDir _ _ = return ()
-- |Copies a file, directory or symlink. In case of a symlink, it is just
-- recreated, even if it points to a directory.
easyCopy :: DirCopyMode
-> AnchoredFile FileInfo
-> AnchoredFile FileInfo
-> IO ()
easyCopy _ from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = recreateSymlink from to
easyCopy _ from@(_ :/ RegFile fn _)
to@(_ :/ Dir {})
= copyFileToDir from to
easyCopy _ from@(_ :/ RegFile fn _)
to@(_ :/ RegFile {})
= copyFile from to
easyCopy cm from@(_ :/ Dir fn _)
to@(_ :/ Dir {})
= copyDir cm from to
easyCopy _ _ _ = return ()
---------------------
--[ File Deletion ]--
---------------------
-- |Deletes a symlink, which can either point to a file or directory.
deleteSymlink :: AnchoredFile FileInfo -> IO ()
deleteSymlink f@(_ :/ SymLink {})
= removeLink (fullPath f)
deleteSymlink _
= return ()
-- |Deletes the given file, never symlinks.
deleteFile :: AnchoredFile FileInfo -> IO ()
deleteFile (_ :/ SymLink {}) = return ()
deleteFile f@(_ :/ RegFile {})
= removeLink (fullPath f)
deleteFile _
= return ()
-- |Deletes the given directory, never symlinks.
deleteDir :: AnchoredFile FileInfo -> IO ()
deleteDir (_ :/ SymLink {}) = return ()
deleteDir f@(_ :/ Dir {})
= removeDirectory (fullPath f)
deleteDir _ = return ()
-- |Deletes the given directory recursively, never symlinks.
deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
deleteDirRecursive (_ :/ SymLink {}) = return ()
deleteDirRecursive f@(_ :/ Dir {})
= removeDirectoryRecursive (fullPath f)
deleteDirRecursive _ = return ()
-- |Deletes a file, directory or symlink, whatever it may be.
-- In case of directory, performs recursive deletion. In case of
-- a symlink, the symlink file is deleted.
easyDelete :: AnchoredFile FileInfo -> IO ()
easyDelete f@(_ :/ SymLink {}) = deleteSymlink f
easyDelete f@(_ :/ RegFile {})
= deleteFile f
easyDelete f@(_ :/ Dir {})
= deleteDirRecursive f
easyDelete _
= return ()
--------------------
--[ File Opening ]--
--------------------
-- |Opens a file appropriately by invoking xdg-open.
openFile :: AnchoredFile a
-> IO ProcessHandle
openFile f = spawnProcess "xdg-open" [fullPath f]
-- |Executes a program with the given arguments.
executeFile :: AnchoredFile FileInfo -- ^ program
-> [String] -- ^ arguments
-> IO (Maybe ProcessHandle)
executeFile prog@(_ :/ RegFile {}) args
= Just <$> spawnProcess (fullPath prog) args
executeFile _ _ = return Nothing
---------------------
--[ File Creation ]--
---------------------
createFile :: AnchoredFile FileInfo -> FileName -> IO ()
createFile (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn
throwFileDoesExist fullp
fd <- System.Posix.IO.createFile fullp newFilePerms
closeFd fd
createFile _ _ = return ()
createDir :: AnchoredFile FileInfo -> FileName -> IO ()
createDir (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn
throwDirDoesExist fullp
createDirectory fullp newFilePerms
createDir _ _ = return ()
----------------------------
--[ File Renaming/Moving ]--
----------------------------
renameFile :: AnchoredFile FileInfo -> FileName -> IO ()
renameFile (_ :/ Failed {}) _ = return ()
renameFile af (ValFN fn) = do
let fromf = fullPath af
tof = anchor af </> fn
throwFileDoesExist tof
throwSameFile fromf tof
rename fromf tof
renameFile _ _ = return ()
-- |Move a given file to the given target directory.
moveFile :: AnchoredFile FileInfo -- ^ file to move
-> AnchoredFile FileInfo -- ^ base target directory
-> IO ()
moveFile from to@(_ :/ Dir {}) = do
let from' = fullPath from
to' = fullPath to </> (name . file $ from)
throwFileDoesExist to'
throwSameFile from' to'
-- TODO: don't catch all exceptions!
handle (\(SomeException e) -> do
easyCopy Strict from to
easyDelete from
) $ rename from' to'
moveFile _ _ = return ()
-----------------------
--[ File Permissions]--
-----------------------
newFilePerms :: FileMode
newFilePerms
= ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
newDirPerms :: FileMode
newDirPerms
= ownerModes
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode

19
src/HSFM/Utils/IO.hs → src/IO/Utils.hs
View File

@@ -1,6 +1,6 @@
{-- {--
HSFM, a filemanager written in Haskell. HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License modify it under the terms of the GNU General Public License
@@ -18,9 +18,8 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |Random and general IO utilities. -- |Random and general IO utilities.
module HSFM.Utils.IO where module IO.Utils where
import Control.Concurrent.STM import Control.Concurrent.STM
@@ -33,14 +32,24 @@ import Control.Concurrent.STM.TVar
, modifyTVar , modifyTVar
, TVar , TVar
) )
import Control.Monad
(
when
, unless
)
-- |Atomically write a TVar.
writeTVarIO :: TVar a -> a -> IO () writeTVarIO :: TVar a -> a -> IO ()
writeTVarIO tvar val = atomically $ writeTVar tvar val writeTVarIO tvar val = atomically $ writeTVar tvar val
-- |Atomically modify a TVar.
modifyTVarIO :: TVar a -> (a -> a) -> IO () modifyTVarIO :: TVar a -> (a -> a) -> IO ()
modifyTVarIO tvar f = atomically $ modifyTVar tvar f modifyTVarIO tvar f = atomically $ modifyTVar tvar f
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb a = mb >>= (`when` a)
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb a = mb >>= (`unless` a)

14
src/HSFM/GUI/Gtk/Callbacks.hs-boot → src/MyPrelude.hs
View File

@@ -1,6 +1,6 @@
{-- {--
HSFM, a filemanager written in Haskell. HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License modify it under the terms of the GNU General Public License
@@ -16,10 +16,12 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
module MyPrelude where
module HSFM.GUI.Gtk.Callbacks where
import HSFM.GUI.Gtk.Data
setViewCallbacks :: MyGUI -> MyView -> IO () import Data.List
listIndices :: [a] -> [Int]
listIndices = findIndices (const True)