Skip build with 7.8.4, which has annoying failures

This fixes 'cabal check' warnings.

.gitignore

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

.gitmodules

@@ -1,9 +0,0 @@
-[submodule "3rdparty/hpath"]
-	path = 3rdparty/hpath
-	url = https://github.com/hasufell/hpath.git
-[submodule "3rdparty/hinotify"]
-	path = 3rdparty/hinotify
-	url = https://github.com/hasufell/hinotify.git
-[submodule "3rdparty/simple-sendfile"]
-	path = 3rdparty/simple-sendfile
-	url = https://github.com/hasufell/simple-sendfile.git

.travis.yml

@@ -0,0 +1,55 @@
+# 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
+

HACKING.md

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

README.md

@@ -1,7 +1,7 @@
 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.__
+[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](http://travis-ci.org/hasufell/hsfm)
 
 A Gtk+:3 filemanager written in Haskell.
 
@@ -15,12 +15,16 @@ Design goals:
 Screenshots
 -----------
 
-![Image missing](https://cloud.githubusercontent.com/assets/1241845/14584163/6dbef950-0439-11e6-8a6e-2352c048775e.png "hsfm-gtk")
+![hsfm](https://cloud.githubusercontent.com/assets/1241845/14768900/06efd43c-0a4d-11e6-939e-6b067bdb47ce.png "hsfm-gtk")
 
 Installation
 ------------
 
 ```
+cabal sandbox init
+cabal install alex happy
+export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
+cabal install gtk2hs-buildtools
 cabal install
 ```
 

data/Gtk/builder.xml

@@ -2,113 +2,281 @@
 <!-- Generated with glade 3.18.3 -->
 <interface>
   <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">
     <property name="visible">True</property>
     <property name="can_focus">False</property>
     <property name="stock">gtk-edit</property>
   </object>
-  <object class="GtkMenu" id="rcMenu">
-    <property name="visible">True</property>
-    <property name="can_focus">False</property>
-    <child>
-      <object class="GtkImageMenuItem" id="rcFileOpen">
-        <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="rcFileExecute">
-        <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="rcFileNew">
-        <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="separatormenuitem2">
-        <property name="visible">True</property>
-        <property name="can_focus">False</property>
-      </object>
-    </child>
-    <child>
-      <object class="GtkImageMenuItem" id="rcFileCut">
-        <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="rcFileCopy">
-        <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="rcFileRename">
-        <property name="label">Rename</property>
-        <property name="visible">True</property>
-        <property name="can_focus">False</property>
-        <property name="image">image1</property>
-        <property name="use_stock">False</property>
-      </object>
-    </child>
-    <child>
-      <object class="GtkImageMenuItem" id="rcFilePaste">
-        <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="rcFileDelete">
-        <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>
   <object class="GtkImage" id="image2">
     <property name="visible">True</property>
     <property name="can_focus">False</property>
-    <property name="stock">gtk-edit</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="GtkImage" id="image4">
-    <property name="visible">True</property>
-    <property name="can_focus">False</property>
-    <property name="stock">gtk-zoom-fit</property>
-  </object>
-  <object class="GtkImage" id="image5">
-    <property name="visible">True</property>
-    <property name="can_focus">False</property>
-    <property name="stock">gtk-zoom-fit</property>
-  </object>
   <object class="GtkApplicationWindow" id="rootWin">
     <property name="can_focus">False</property>
     <child>
@@ -130,33 +298,6 @@
                   <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>
@@ -176,65 +317,6 @@
                 </child>
               </object>
             </child>
-            <child>
-              <object class="GtkMenuItem" id="menubarEdit">
-                <property name="visible">True</property>
-                <property name="can_focus">False</property>
-                <property name="label" translatable="yes">_Edit</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>
@@ -244,24 +326,6 @@
                   <object class="GtkMenu" id="menu5">
                     <property name="visible">True</property>
                     <property name="can_focus">False</property>
-                    <child>
-                      <object class="GtkImageMenuItem" id="menubarViewTree">
-                        <property name="label">Tree View</property>
-                        <property name="visible">True</property>
-                        <property name="can_focus">False</property>
-                        <property name="image">image4</property>
-                        <property name="use_stock">False</property>
-                      </object>
-                    </child>
-                    <child>
-                      <object class="GtkImageMenuItem" id="menubarViewIcon">
-                        <property name="label">Icon view</property>
-                        <property name="visible">True</property>
-                        <property name="can_focus">False</property>
-                        <property name="image">image5</property>
-                        <property name="use_stock">False</property>
-                      </object>
-                    </child>
                   </object>
                 </child>
               </object>
@@ -297,82 +361,28 @@
           </packing>
         </child>
         <child>
-          <object class="GtkBox" id="box2">
+          <object class="GtkNotebook" id="notebook">
-            <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>
-                <property name="expand">True</property>
-                <property name="fill">True</property>
-                <property name="position">0</property>
-              </packing>
-            </child>
-            <child>
-              <object class="GtkButton" id="upViewB">
-                <property name="label">gtk-go-up</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">2</property>
-                <property name="position">1</property>
-              </packing>
-            </child>
-            <child>
-              <object class="GtkButton" id="homeViewB">
-                <property name="label">gtk-home</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="position">2</property>
-              </packing>
-            </child>
-            <child>
-              <object class="GtkButton" id="refreshViewB">
-                <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">2</property>
-                <property name="position">3</property>
-              </packing>
-            </child>
-          </object>
-          <packing>
-            <property name="expand">False</property>
-            <property name="fill">True</property>
-            <property name="position">1</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>
+            <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>
@@ -430,4 +440,267 @@
       </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">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <child>
+      <object class="GtkImageMenuItem" id="rcFileOpen">
+        <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="rcFileExecute">
+        <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="rcFileNew">
+        <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>
+        <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>
+    </child>
+    <child>
+      <object class="GtkSeparatorMenuItem" id="separatormenuitem2">
+        <property name="visible">True</property>
+        <property name="can_focus">False</property>
+      </object>
+    </child>
+    <child>
+      <object class="GtkImageMenuItem" id="rcFileCut">
+        <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="rcFileCopy">
+        <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="rcFileRename">
+        <property name="label">Rename</property>
+        <property name="visible">True</property>
+        <property name="can_focus">False</property>
+        <property name="image">image1</property>
+        <property name="use_stock">False</property>
+      </object>
+    </child>
+    <child>
+      <object class="GtkImageMenuItem" id="rcFilePaste">
+        <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="rcFileDelete">
+        <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>
+    <child>
+      <object class="GtkImageMenuItem" id="rcFileProperty">
+        <property name="label">gtk-properties</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="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="can_focus">False</property>
+            <child>
+              <object class="GtkImageMenuItem" id="rcFileIconView">
+                <property name="label">icon view</property>
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="image">image4</property>
+                <property name="use_stock">False</property>
+              </object>
+            </child>
+            <child>
+              <object class="GtkImageMenuItem" id="rcFileTreeView">
+                <property name="label" translatable="yes">tree view</property>
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="image">image5</property>
+                <property name="use_stock">False</property>
+              </object>
+            </child>
+          </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>
+            <property name="expand">True</property>
+            <property name="fill">True</property>
+            <property name="position">0</property>
+          </packing>
+        </child>
+        <child>
+          <object class="GtkButton" id="upViewB">
+            <property name="label">gtk-go-up</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">2</property>
+            <property name="position">1</property>
+          </packing>
+        </child>
+        <child>
+          <object class="GtkButton" id="homeViewB">
+            <property name="label">gtk-home</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="position">2</property>
+          </packing>
+        </child>
+        <child>
+          <object class="GtkButton" id="refreshViewB">
+            <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">2</property>
+            <property name="position">3</property>
+          </packing>
+        </child>
+      </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>
+  </object>
 </interface>

hacking/HACKING.md

@@ -1,37 +1,23 @@
-HACKING
+# 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
+## Coding style
-------------
 
 - match the sorroundings
 - no overcomplicated pointfree style
 - normal indenting 2 whitespaces
 - just make things pretty and readable
-- use the provided [hsimport.hs](hsimport.hs)
+- you can use the provided [hsimport.hs](hsimport.hs)
 
-Documentation
+## Documentation
--------------
 
 __Everything__ must be documented. :)
+Don't assume people know what you mean. Type signatures are not sufficient
+documentation.
 
-Hacking Guide
+## Hacking Overview
--------------
-
-The main data structure for the IO related File type is in
-[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
-should be seen as a library. This is the entry point where
-[directory contents are read](./../src/HSFM/FileSystem/FileType.hs#L465)
-and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
-The File type uses a safe Path type under the hood instead of Strings,
-utilizing the [hpath](https://github.com/hasufell/hpath) library.
-
-File operations (like copy, delete etc) are defined at
-[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
-which use this File type.
 
 Only a GTK GUI is currently implemented, the entry point being
 [HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down
@@ -52,3 +38,68 @@ following files:
 * [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.
+

hacking/hsimport.hs

@@ -8,7 +8,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
    where
       prettyPrint :: HS.ImportDecl -> String
       prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
-        "import " ++ (ifStr qual "qualified") ++
+        "import " ++ (ifStr qual "qualified ") ++
         (maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg)  ++
         getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
         specprint mspec
@@ -16,9 +16,9 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
       specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
       specprint Nothing = ""
       specprint (Just (False, xs))
-        = "\n  (\n" ++ printImportSpecs xs ++ "\n  )"
+        = "\n  (\n" ++ printImportSpecs xs ++ "  )"
       specprint (Just (True, xs))
-        = "\n  hiding (\n" ++ printImportSpecs xs ++ "\n  )"
+        = "\n  hiding (\n" ++ printImportSpecs xs ++ "  )"
 
       printImportSpecs :: [HS.ImportSpec] -> String
       printImportSpecs ins
@@ -26,7 +26,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
             in  "    " ++ printSpec x ++ "\n" ++ go xs
         where
           go []       = ""
-          go [x']     = "  , " ++ printSpec x'
+          go [x']     = "  , " ++ printSpec x' ++ "\n"
           go (x':xs') = "  , " ++ printSpec x' ++ "\n" ++ go xs'
           printSpec :: HS.ImportSpec -> String
           printSpec = HS.prettyPrint

hsfm.cabal

@@ -10,7 +10,7 @@ copyright:           Copyright: (c) 2016 Julian Ospald
 homepage:            https://github.com/hasufell/hsfm
 category:            Desktop
 build-type:          Simple
-cabal-version:       >=1.10
+cabal-version:       >=1.24
 
 data-files:
                      LICENSE
@@ -24,30 +24,22 @@ data-files:
 
 library
   exposed-modules:
-                       HSFM.FileSystem.Errors
-                       HSFM.FileSystem.FileOperations
                        HSFM.FileSystem.FileType
+                       HSFM.FileSystem.UtilTypes
                        HSFM.Utils.IO
                        HSFM.Utils.MyPrelude
 
   build-depends:
-                       base >= 4.7,
+                       base >= 4.8 && < 5,
                        bytestring,
-                       containers,
                        data-default,
                        filepath >= 1.3.0.0,
-                       hinotify,
+                       hinotify-bytestring,
-                       hpath,
+                       hpath >= 0.7.1,
-                       mtl >= 2.2,
-                       old-locale >= 1,
-                       posix-paths,
-                       process,
                        safe,
-                       simple-sendfile,
                        stm,
                        time >= 1.4.2,
                        unix,
-                       unix-bytestring,
                        utf8-string
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -56,16 +48,14 @@ library
                        FlexibleInstances
                        ViewPatterns
   ghc-options:
-    -O2
-    -threaded
     -Wall
-    "-with-rtsopts=-N"
 
 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
@@ -76,20 +66,17 @@ executable hsfm-gtk
                        HSFM.Utils.MyPrelude
 
   build-depends:
-                       Cabal >= 1.22.0.0,
+                       Cabal >= 1.24.0.0,
-                       base >= 4.7,
+                       base >= 4.8 && < 5,
                        bytestring,
-                       containers,
                        data-default,
                        filepath >= 1.3.0.0,
                        glib >= 0.13,
                        gtk3 >= 0.14.1,
-                       hinotify,
+                       hinotify-bytestring,
-                       hpath,
+                       hpath >= 0.7.1,
                        hsfm,
-                       mtl >= 2.2,
                        old-locale >= 1,
-                       posix-paths,
                        process,
                        safe,
                        simple-sendfile,
@@ -107,7 +94,9 @@ executable hsfm-gtk
                        FlexibleInstances
                        ViewPatterns
   ghc-options:
-    -O2
-    -threaded
     -Wall
-    "-with-rtsopts=-N"
+
+source-repository head
+  type:     git
+  location: https://github.com/hasufell/hsfm
+

src/HSFM/FileSystem/Errors.hs

@@ -1,251 +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.
-module HSFM.FileSystem.Errors where
-
-
-import Control.Exception
-import Control.Monad
-  (
-    when
-  , forM
-  )
-import Data.ByteString
-  (
-    ByteString
-  )
-import Data.Typeable
-import Foreign.C.Error
-  (
-    getErrno
-  , Errno
-  )
-import qualified HPath as P
-import HPath
-    (
-      Abs
-    , Path
-    )
-import HSFM.Utils.IO
-import System.IO.Error
-  (
-    catchIOError
-  )
-
-import qualified System.Posix.Directory.ByteString as PFD
-import System.Posix.FilePath
-import qualified System.Posix.Files.ByteString as PF
-
-
-data FmIOException = FileDoesNotExist ByteString
-                   | DirDoesNotExist ByteString
-                   | PathNotAbsolute ByteString
-                   | FileNotExecutable ByteString
-                   | SameFile ByteString ByteString
-                   | NotAFile ByteString
-                   | NotADir ByteString
-                   | DestinationInSource ByteString ByteString
-                   | FileDoesExist ByteString
-                   | DirDoesExist ByteString
-                   | IsSymlink ByteString
-                   | InvalidOperation String
-                   | InvalidFileName
-                   | Can'tOpenDirectory ByteString
-                   | CopyFailed String
-                   | MoveFailed String
-  deriving (Typeable)
-
-
-instance Show FmIOException where
-  show (FileDoesNotExist fp) = "File does not exist:" ++ P.fpToString fp
-  show (DirDoesNotExist fp) = "Directory does not exist: "
-                              ++ P.fpToString fp
-  show (PathNotAbsolute fp) = "Path not absolute: " ++ P.fpToString fp
-  show (FileNotExecutable fp) = "File not executable: "
-                                ++ P.fpToString fp
-  show (SameFile fp1 fp2) = P.fpToString fp1
-                            ++ " and " ++ P.fpToString fp2
-                            ++ " are the same file!"
-  show (NotAFile fp) = "Not a file: " ++ P.fpToString fp
-  show (NotADir fp) = "Not a directory: " ++ P.fpToString fp
-  show (DestinationInSource fp1 fp2) = P.fpToString fp1
-                                       ++ " is contained in "
-                                       ++ P.fpToString fp2
-  show (FileDoesExist fp) = "File does exist: " ++ P.fpToString fp
-  show (DirDoesExist fp) = "Directory does exist: " ++ P.fpToString fp
-  show (IsSymlink fp) = "Is a symlink: " ++ P.fpToString fp
-  show (InvalidOperation str) = "Invalid operation: " ++ str
-  show InvalidFileName = "Invalid file name!"
-  show (Can'tOpenDirectory fp) = "Can't open directory: "
-                                 ++ P.fpToString fp
-  show (CopyFailed str) = "Copying failed: " ++ str
-  show (MoveFailed str) = "Moving failed: " ++ str
-
-
-
-instance Exception FmIOException
-
-
-
-
-    ----------------------------
-    --[ Path based functions ]--
-    ----------------------------
-
-
-throwFileDoesExist :: Path Abs -> IO ()
-throwFileDoesExist fp =
-  whenM (doesFileExist fp) (throw . FileDoesExist
-                                  . P.fromAbs $ fp)
-
-
-throwDirDoesExist :: Path Abs -> IO ()
-throwDirDoesExist fp =
-  whenM (doesDirectoryExist fp) (throw . DirDoesExist
-                                       . P.fromAbs $ fp)
-
-
-throwFileDoesNotExist :: Path Abs -> IO ()
-throwFileDoesNotExist fp =
-  whenM (doesFileExist fp) (throw . FileDoesExist
-                                  . P.fromAbs $ fp)
-
-
-throwDirDoesNotExist :: Path Abs -> IO ()
-throwDirDoesNotExist fp =
-  whenM (doesDirectoryExist fp) (throw . DirDoesExist
-                                       . P.fromAbs $ fp)
-
-
-throwSameFile :: Path Abs -- ^ will be canonicalized
-              -> Path Abs -- ^ will be canonicalized
-              -> IO ()
-throwSameFile fp1 fp2 = do
-  fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1
-  -- TODO: clean this up... if canonicalizing fp2 fails we try to
-  --       canonicalize `dirname fp2`
-  fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
-                       (\_ -> fmap P.fromAbs
-                       $ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
-                                <$> (P.canonicalizePath $ P.dirname fp2))
-  when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
-
-
--- |Checks whether the destination directory is contained
--- within the source directory by comparing the device+file ID of the
--- source directory with all device+file IDs of the parent directories
--- of the destination.
-throwDestinationInSource :: Path Abs -- ^ source dir
-                         -> Path Abs -- ^ full destination, `dirname dest`
-                                     --   must exist
-                         -> IO ()
-throwDestinationInSource source dest = do
-  source' <- P.canonicalizePath source
-  dest'   <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
-             <$> (P.canonicalizePath $ P.dirname dest)
-  dids <- forM (P.getAllParents dest') $ \p -> do
-          fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
-          return (PF.deviceID fs, PF.fileID fs)
-  sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
-              $ PF.getSymbolicLinkStatus (P.fromAbs source')
-  when (elem sid dids)
-       (throw $ DestinationInSource (P.fromAbs dest)
-                                    (P.fromAbs source))
-
-
--- |Checks if the given file exists and is not a directory. This follows
--- symlinks, but will return True if the symlink is broken.
-doesFileExist :: Path Abs -> IO Bool
-doesFileExist fp =
-  handleIOError (\_ -> return False) $ do
-    fp' <- fmap P.fromAbs $ P.canonicalizePath fp
-    fs  <- PF.getFileStatus fp'
-    return $ not . PF.isDirectory $ fs
-
-
--- |Checks if the given file exists and is a directory. This follows
--- symlinks, but will return False if the symlink is broken.
-doesDirectoryExist :: Path Abs -> IO Bool
-doesDirectoryExist fp =
-  handleIOError (\_ -> return False) $ do
-    fp' <- fmap P.fromAbs $ P.canonicalizePath fp
-    fs  <- PF.getFileStatus fp'
-    return $ PF.isDirectory fs
-
-
--- |Checks whether the directory at the given path exists and can be
--- opened. This invokes `openDirStream`.
-canOpenDirectory :: Path Abs -> IO Bool
-canOpenDirectory fp =
-  handleIOError (\_ -> return False) $ do
-    bracket (PFD.openDirStream . P.fromAbs $ fp)
-            PFD.closeDirStream
-            (\_ -> return ())
-    return True
-
-
--- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given
--- path cannot be opened.
-throwCantOpenDirectory :: Path Abs -> IO ()
-throwCantOpenDirectory fp =
-  unlessM (canOpenDirectory fp)
-          (throw . Can'tOpenDirectory . P.fromAbs $ fp)
-
-
-
-    --------------------------------
-    --[ Error handling functions ]--
-    --------------------------------
-
-
--- |Carries out an action, then checks if there is an IOException and
--- a specific errno. If so, then it carries out another action, otherwise
--- it rethrows the error.
-catchErrno :: [Errno] -- ^ errno to catch
-           -> IO a    -- ^ action to try, which can raise an IOException
-           -> IO a    -- ^ action to carry out in case of an IOException and
-                      --   if errno matches
-           -> IO a
-catchErrno en a1 a2 =
-  catchIOError a1 $ \e -> do
-    errno <- getErrno
-    if errno `elem` en
-      then a2
-      else ioError e
-
-
--- |Execute the given action and retrow IO exceptions as a new Exception
--- that have the given errno. If errno does not match the exception is rethrown
--- as is.
-rethrowErrnoAs :: Exception e
-               => [Errno]       -- ^ errno to catch
-               -> e             -- ^ rethrow as if errno matches
-               -> IO a          -- ^ action to try
-               -> IO a
-rethrowErrnoAs en fmex action = catchErrno en action (throw fmex)
-
-
-
--- |Like `catchIOError`, with arguments swapped.
-handleIOError :: (IOError -> IO a) -> IO a -> IO a
-handleIOError = flip catchIOError
-

src/HSFM/FileSystem/FileOperations.hs

@@ -1,611 +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 PackageImports #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
--- |This module provides all the atomic IO related file operations like
--- copy, delete, move and so on. It operates primarily on `AnchoredFile`, which
--- is guaranteed to be well-formed.
---
--- 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 HSFM.FileSystem.FileOperations where
-
-
-import Control.Exception
-  (
-    bracket
-  , throw
-  )
-import Control.Monad
-  (
-    unless
-  , void
-  , when
-  )
-import Data.ByteString
-  (
-    ByteString
-  )
-import Data.Foldable
-  (
-    for_
-  )
-import Data.Word
-  (
-    Word8
-  )
-import Foreign.C.Error
-  (
-    eXDEV
-  , eINVAL
-  , eNOSYS
-  )
-import Foreign.C.Types
-  (
-    CSize
-  )
-import Foreign.Marshal.Alloc
-  (
-    allocaBytes
-  )
-import Foreign.Ptr
-  (
-    Ptr
-  )
-import HPath
-  (
-    Path
-  , Abs
-  , Fn
-  )
-import qualified HPath as P
-import HSFM.FileSystem.Errors
-import HSFM.FileSystem.FileType
-import HSFM.Utils.IO
-import Prelude hiding (readFile)
-import System.Posix.Directory.ByteString
-  (
-    createDirectory
-  , removeDirectory
-  )
-import System.Posix.Files.ByteString
-  (
-    createSymbolicLink
-  , fileMode
-  , getFdStatus
-  , groupExecuteMode
-  , groupReadMode
-  , groupWriteMode
-  , otherExecuteMode
-  , otherReadMode
-  , otherWriteMode
-  , ownerModes
-  , ownerReadMode
-  , ownerWriteMode
-  , readSymbolicLink
-  , removeLink
-  , rename
-  , unionFileModes
-  )
-import qualified System.Posix.Files.ByteString as PF
-import qualified "unix" System.Posix.IO.ByteString as SPI
-import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB
-import System.Posix.IO.Sendfile.ByteString
-  (
-    sendfileFd
-  , FileRange(EntireFile)
-  )
-import qualified System.Posix.Process.ByteString as SPP
-import System.Posix.Types
-  (
-    FileMode
-  , ProcessID
-  , Fd
-  )
-
-
-
--- TODO: file operations should be threaded and not block the UI
--- TODO: make sure we do the right thing for BlockDev, CharDev etc...
---       most operations are not implemented for these
-
-
--- |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  [Path Abs]
-                   | FOpen    (Path Abs)
-                   | FExecute (Path Abs) [ByteString]
-                   | 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 [Path Abs]
-          | CP2 [Path Abs]
-                (Path Abs)
-          | CC  [Path Abs]
-                (Path Abs)
-                CopyMode
-
-
--- |Data type describing partial or complete file move operation.
--- MC stands for a complete operation and can be used for `runFileOp`.
-data Move = MP1 [Path Abs]
-          | MC  [Path Abs]
-                (Path Abs)
-                CopyMode
-
-
--- |Copy modes.
-data CopyMode = Strict  -- ^ fail if the target already exists
-              | Merge   -- ^ overwrite files if necessary, for files, this
-                        --   is the same as Replace
-              | Replace -- ^ remove targets before copying, this is
-                        --   only useful if the target is a directorty
-              | Rename (Path Fn)
-
-
--- |Run a given FileOperation. If the FileOperation is partial, it will
--- be returned. Returns `Nothing` on success.
---
--- Since file operations can be delayed, this is `Path Abs` based, not
--- `File` based. This makes sure we don't have stale
--- file information.
-runFileOp :: FileOperation -> IO (Maybe FileOperation)
-runFileOp fo' =
-  case fo' of
-    (FCopy (CC froms to cm)) -> do
-      froms' <- mapM toAfile froms
-      to'    <- toAfile to
-      when (anyFailed froms')
-           (throw . CopyFailed $ "File in copy buffer does not exist anymore!")
-      mapM_ (\x -> easyCopy cm x to') froms'
-        >> return Nothing
-    (FCopy fo) -> return $ Just $ FCopy fo
-    (FMove (MC froms to cm)) -> do
-      froms' <- mapM toAfile froms
-      to'   <- toAfile to
-      when (anyFailed froms')
-           (throw . MoveFailed $ "File in move buffer does not exist anymore!")
-      mapM_ (\x -> easyMove cm x to') froms'
-        >> return Nothing
-    (FMove fo) -> return $ Just $ FMove fo
-    (FDelete fps) -> do
-      fps' <- mapM toAfile fps
-      mapM_ easyDelete fps' >> return Nothing
-    (FOpen fp) ->
-      toAfile fp >>= openFile >> return Nothing
-    (FExecute fp args) ->
-      toAfile fp >>= flip executeFile args >> return Nothing
-    _ -> return Nothing
-  where
-    toAfile = readFile (\_ -> return undefined)
-
-
-
-    --------------------
-    --[ File Copying ]--
-    --------------------
-
-
--- |Copies a directory to the given destination with the specified
--- `DirCopyMode`. Excludes symlinks.
-copyDir :: CopyMode
-        -> File a  -- ^ source dir
-        -> File a  -- ^ destination dir
-        -> Path Fn -- ^ destination dir name
-        -> IO ()
-copyDir       (Rename fn)
-         from@Dir{}
-           to@Dir{}
-           _
-  = copyDir Strict from to fn
--- this branch must never get `Rename` as CopyMode
-copyDir cm from@Dir{ path = fromp }
-             to@Dir{ path = top }
-             fn
-  = do
-    let destdirp = top P.</> fn
-    -- for performance, sanity checks are only done for the top dir
-    throwDestinationInSource fromp destdirp
-    throwSameFile fromp destdirp
-    throwCantOpenDirectory fromp
-    throwCantOpenDirectory top
-    go cm from to fn
-  where
-    go :: CopyMode -> File a -> File a -> Path Fn -> IO ()
-    go cm' Dir{ path = fromp' }
-           Dir{ path = top' }
-           fn' = do
-      fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus
-                                   (P.fromAbs fromp')
-      createDestdir (top' P.</> fn') fmode'
-      destdir <- readFile (\_ -> return undefined)
-                   (top' P.</> fn')
-      contents <- readDirectoryContents
-                    (\_ -> return undefined) fromp'
-
-      for_ contents $ \f ->
-        case f of
-          SymLink{ path = fp' }  -> recreateSymlink cm' f destdir
-                                      =<< (P.basename fp')
-          Dir{ path = fp' }      -> go cm' f destdir
-                                      =<< (P.basename fp')
-          RegFile{ path = fp' }  -> unsafeCopyFile Replace f destdir
-                                      =<< (P.basename fp')
-          _                      -> return ()
-      where
-        createDestdir destdir fmode' =
-          let destdir' = P.toFilePath destdir
-          in case cm' of
-            Merge   ->
-              unlessM (doesDirectoryExist destdir)
-                      (createDirectory destdir' fmode')
-            Strict  -> do
-              throwDirDoesExist destdir
-              createDirectory destdir' fmode'
-            Replace -> do
-              whenM (doesDirectoryExist destdir)
-                    (deleteDirRecursive =<<
-                       readFile
-                         (\_ -> return undefined) destdir)
-              createDirectory destdir' fmode'
-            _ -> throw $ InvalidOperation "Internal error, wrong CopyMode!"
-    go _ _ _ _ = throw $ InvalidOperation "wrong input type"
-copyDir _ _ _ _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Recreate a symlink.
-recreateSymlink :: CopyMode
-                -> File a  -- ^ the old symlink file
-                -> File a  -- ^ destination dir of the
-                           --   new symlink file
-                -> Path Fn -- ^ destination file name
-                -> IO ()
-recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _
-  = recreateSymlink Strict symf symdest pn
-recreateSymlink cm SymLink{ path = sfp } Dir{ path = sdp } fn
-  = do
-    throwCantOpenDirectory sdp
-    sympoint <- readSymbolicLink (P.fromAbs sfp)
-    let symname = sdp P.</> fn
-    case cm of
-      Merge   -> delOld symname
-      Replace -> delOld symname
-      _       -> return ()
-    createSymbolicLink sympoint (P.fromAbs symname)
-  where
-    delOld symname = do
-      f <- readFile (\_ -> return undefined) symname
-      unless (failed f)
-             (easyDelete f)
-recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Copies the given regular file to the given dir with the given filename.
--- Excludes symlinks.
-copyFile :: CopyMode
-         -> File a  -- ^ source file
-         -> File a  -- ^ destination dir
-         -> Path Fn -- ^ destination file name
-         -> IO ()
-copyFile (Rename pn) from@RegFile{} to@Dir{} _
-  = copyFile Strict from to pn
-copyFile cm from@RegFile{ path = fromp }
-             tod@Dir{ path = todp } fn
-  = do
-    throwCantOpenDirectory todp
-    throwCantOpenDirectory . P.dirname $ fromp
-    throwSameFile fromp (todp P.</> fn)
-    unsafeCopyFile cm from tod fn
-copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Unsafe version of `copyFile` without initial sanity checks. This
--- holds the actual copy logic though and is called by `copyFile` in the end.
--- It's also used for cases where we don't need/want sanity checks
--- and need the extra bit of performance.
-unsafeCopyFile :: CopyMode
-               -> File a  -- ^ source file
-               -> File a  -- ^ destination dir
-               -> Path Fn -- ^ destination file name
-               -> IO ()
-unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _
-  = copyFile Strict from to pn
-unsafeCopyFile cm RegFile{ path = fromp }
-                  Dir{ path = todp } fn
-  = do
-    let to = todp P.</> fn
-    case cm of
-      Strict -> throwFileDoesExist to
-      _      -> return ()
-
-    -- from sendfile(2) manpage:
-    --   Applications  may  wish  to  fall back to read(2)/write(2) in the case
-    --   where sendfile() fails with EINVAL or ENOSYS.
-    P.withAbsPath to $ \to' -> P.withAbsPath fromp $ \from' ->
-      catchErrno [eINVAL, eNOSYS]
-                 (sendFileCopy from' to')
-                 (void $ fallbackCopy from' to')
-  where
-    -- this is low-level stuff utilizing sendfile(2) for speed
-    sendFileCopy source dest =
-      -- NOTE: we are not blocking IO here, O_NONBLOCK is false
-      -- for `defaultFileFlags`
-      bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
-              SPI.closeFd
-              $ \sfd -> do
-                fileM <- System.Posix.Files.ByteString.fileMode
-                         <$> getFdStatus sfd
-                bracket (SPI.openFd dest SPI.WriteOnly (Just fileM)
-                                    SPI.defaultFileFlags)
-                        SPI.closeFd
-                        $ \dfd -> sendfileFd dfd sfd EntireFile
-    -- low-level copy operation utilizing read(2)/write(2)
-    -- in case `sendFileCopy` fails/is unsupported
-    fallbackCopy source dest =
-      bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
-              SPI.closeFd
-              $ \sfd -> do
-                fileM <- System.Posix.Files.ByteString.fileMode
-                         <$> getFdStatus sfd
-                bracket (SPI.openFd dest SPI.WriteOnly (Just fileM)
-                                    SPI.defaultFileFlags)
-                        SPI.closeFd
-                        $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf ->
-                                    write' sfd dfd buf 0
-      where
-        bufSize :: CSize
-        bufSize = 8192
-        write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int
-        write' sfd dfd buf totalsize = do
-            size <- SPB.fdReadBuf sfd buf bufSize
-            if size == 0
-              then return $ fromIntegral totalsize
-              else do rsize <- SPB.fdWriteBuf dfd buf size
-                      when (rsize /= size) (throw . CopyFailed $ "wrong size!")
-                      write' sfd dfd buf (totalsize + fromIntegral size)
-unsafeCopyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Copies a regular file, directory or symlink. In case of a symlink,
--- it is just recreated, even if it points to a directory.
-easyCopy :: CopyMode
-         -> File a
-         -> File a
-         -> IO ()
-easyCopy cm from@SymLink{}
-              to@Dir{}
-  = recreateSymlink cm from to =<< (P.basename . path $ from)
-easyCopy cm from@RegFile{}
-              to@Dir{}
-  = copyFile cm from to =<< (P.basename . path $ from)
-easyCopy cm from@Dir{}
-              to@Dir{}
-  = copyDir cm from to =<< (P.basename . path $ from)
-easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
-
-
-
-
-
-    ---------------------
-    --[ File Deletion ]--
-    ---------------------
-
-
--- |Deletes a symlink, which can either point to a file or directory.
-deleteSymlink :: File a -> IO ()
-deleteSymlink SymLink{ path = fp }
-  = P.withAbsPath fp removeLink
-deleteSymlink _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Deletes the given regular file, never symlinks.
-deleteFile :: File a -> IO ()
-deleteFile RegFile{ path = fp }
-  = P.withAbsPath fp removeLink
-deleteFile _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Deletes the given directory, never symlinks.
-deleteDir :: File a -> IO ()
-deleteDir Dir{ path = fp }
-  = P.withAbsPath fp removeDirectory
-deleteDir _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Deletes the given directory recursively.
-deleteDirRecursive :: File a -> IO ()
-deleteDirRecursive f'@Dir{ path = fp' } = do
-  throwCantOpenDirectory fp'
-  go f'
-  where
-    go :: File a -> IO ()
-    go Dir{ path = fp } = do
-      files <- readDirectoryContents
-                 (\_ -> return undefined) fp
-      for_ files $ \file ->
-        case file of
-          SymLink{} -> deleteSymlink file
-          Dir{}     -> go file
-          RegFile{ path = rfp }
-                    -> P.withAbsPath rfp removeLink
-          _         -> throw $ FileDoesExist
-                               (P.toFilePath . path $ file)
-      removeDirectory . P.toFilePath $ fp
-    go _ = throw $ InvalidOperation "wrong input type"
-deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
-
-
--- |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 :: File a -> IO ()
-easyDelete f@SymLink{} = deleteSymlink f
-easyDelete f@RegFile{}
-  = deleteFile f
-easyDelete f@Dir{}
-  = deleteDirRecursive f
-easyDelete _ = throw $ InvalidOperation "wrong input type"
-
-
-
-
-    --------------------
-    --[ File Opening ]--
-    --------------------
-
-
--- |Opens a file appropriately by invoking xdg-open. The file type
--- is not checked.
-openFile :: File a
-         -> IO ProcessID
-openFile f =
-  P.withAbsPath (path f) $ \fp ->
-    SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
-
-
--- |Executes a program with the given arguments.
-executeFile :: File a  -- ^ program
-            -> [ByteString]    -- ^ arguments
-            -> IO ProcessID
-executeFile RegFile{ path = fp } args
-  = P.withAbsPath fp $ \fpb ->
-      SPP.forkProcess
-      $ SPP.executeFile fpb True args Nothing
-executeFile SymLink{ path = fp, sdest = RegFile{} } args
-  = P.withAbsPath fp $ \fpb ->
-      SPP.forkProcess
-      $ SPP.executeFile fpb True args Nothing
-executeFile _ _ = throw $ InvalidOperation "wrong input type"
-
-
-
-
-    ---------------------
-    --[ File Creation ]--
-    ---------------------
-
-
--- |Create an empty regular file at the given directory with the given filename.
-createFile :: File FileInfo -> Path Fn -> IO ()
-createFile (DirOrSym td) fn = do
-  let fullp = path td P.</> fn
-  throwFileDoesExist fullp
-  fd <- SPI.createFile (P.fromAbs fullp) newFilePerms
-  SPI.closeFd fd
-createFile _ _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Create an empty directory at the given directory with the given filename.
-createDir :: File FileInfo -> Path Fn -> IO ()
-createDir (DirOrSym td) fn = do
-  let fullp = path td P.</> fn
-  throwDirDoesExist fullp
-  createDirectory (P.fromAbs fullp) newFilePerms
-createDir _ _ = throw $ InvalidOperation "wrong input type"
-
-
-
-
-    ----------------------------
-    --[ File Renaming/Moving ]--
-    ----------------------------
-
-
--- |Rename a given file with the provided filename.
-renameFile :: File a -> Path Fn -> IO ()
-renameFile af fn = do
-  let fromf = path af
-      tof   = (P.dirname . path $ af) P.</> fn
-  throwFileDoesExist tof
-  throwSameFile fromf tof
-  rename (P.fromAbs fromf) (P.fromAbs tof)
-
-
--- |Move a given file to the given target directory.
-moveFile :: CopyMode
-         -> File a  -- ^ file to move
-         -> File a  -- ^ base target directory
-         -> Path Fn -- ^ target file name
-         -> IO ()
-moveFile (Rename pn) from to@Dir{} _ =
-  moveFile Strict from to pn
-moveFile cm from to@Dir{} fn = do
-  let from'  = path from
-      froms' = P.fromAbs from'
-      to'    = path to P.</> fn
-      tos'   = P.fromAbs to'
-  case cm of
-    Strict   -> throwFileDoesExist to'
-    Merge    -> delOld to'
-    Replace  -> delOld to'
-    Rename _ -> throw $ InvalidOperation "Internal error! Wrong CopyMode!"
-  throwSameFile from' to'
-  catchErrno [eXDEV] (rename froms' tos') $ do
-    easyCopy Strict from to
-    easyDelete from
-  where
-    delOld fp = do
-      to' <- readFile (\_ -> return undefined) fp
-      unless (failed to') (easyDelete to')
-moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-
-
--- |Like `moveFile` except it uses the filename of the source as target.
-easyMove :: CopyMode
-         -> File a -- ^ file to move
-         -> File a -- ^ base target directory
-         -> IO ()
-easyMove cm from to = moveFile cm from to =<< (P.basename . path $ from)
-
-
-
-    -----------------------
-    --[ File Permissions]--
-    -----------------------
-
-
--- |Default permissions for a new file.
-newFilePerms :: FileMode
-newFilePerms
-  =                  ownerWriteMode
-    `unionFileModes` ownerReadMode
-    `unionFileModes` groupWriteMode
-    `unionFileModes` groupReadMode
-    `unionFileModes` otherWriteMode
-    `unionFileModes` otherReadMode
-
-
--- |Default permissions for a new directory.
-newDirPerms :: FileMode
-newDirPerms
-  =                  ownerModes
-    `unionFileModes` groupExecuteMode
-    `unionFileModes` groupReadMode
-    `unionFileModes` otherExecuteMode
-    `unionFileModes` otherReadMode
-

src/HSFM/FileSystem/FileType.hs

@@ -18,39 +18,45 @@ 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.
+-- |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.
 --
--- It doesn't allow to represent the whole filesystem, since that's only
+-- However, it's not meant to be used to interact with low-level
--- possible through IO laziness, which introduces too much internal state.
+-- 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.Default
+import Data.ByteString.UTF8
-import Data.Maybe
   (
-    catMaybes
+    toString
   )
+import Data.Default
 import Data.Time.Clock.POSIX
   (
     POSIXTime
   , posixSecondsToUTCTime
   )
 import Data.Time()
-import Foreign.C.Error
-  (
-    eACCES
-  )
 import HPath
   (
     Abs
   , Path
-  , Fn
   )
 import qualified HPath as P
-import HSFM.FileSystem.Errors
+import HPath.IO hiding (FileType(..))
+import HPath.IO.Errors
 import HSFM.Utils.MyPrelude
 import Prelude hiding(readFile)
 import System.IO.Error
@@ -64,8 +70,7 @@ import System.Posix.FilePath
   )
 import System.Posix.Directory.Traversals
   (
-    getDirectoryContents
+    realpath
-  , realpath
   )
 import qualified System.Posix.Files.ByteString as PF
 import System.Posix.Types
@@ -93,62 +98,61 @@ import System.Posix.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. an Exception
+-- think of. We catch any IO errors in the Failed constructor.
--- can be converted to a String with 'show'.
 data File a =
     Failed {
-    path :: Path Abs
+    path :: !(Path Abs)
   , err  :: IOError
   }
   | Dir {
-    path :: Path Abs
+    path :: !(Path Abs)
   , fvar :: a
   }
   | RegFile {
-    path :: Path Abs
+    path :: !(Path Abs)
   , fvar :: a
   }
   | SymLink {
-    path    :: Path Abs
+    path    :: !(Path Abs)
   , fvar    :: a
   , sdest   :: File a  -- ^ symlink madness,
                        --   we need to know where it points to
-  , rawdest :: ByteString
+  , rawdest :: !ByteString
   }
   | BlockDev {
-    path :: Path Abs
+    path :: !(Path Abs)
   , fvar :: a
   }
   | CharDev {
-    path :: Path Abs
+    path :: !(Path Abs)
   , fvar :: a
   }
   | NamedPipe {
-    path :: Path Abs
+    path :: !(Path Abs)
   , fvar :: a
   }
   | Socket {
-    path :: Path Abs
+    path :: !(Path Abs)
   , fvar :: a
   } deriving (Show, Eq)
 
 
 -- |Low-level file information.
 data FileInfo = FileInfo {
-    deviceID :: DeviceID
+    deviceID              :: !DeviceID
-  , fileID :: FileID
+  , fileID                :: !FileID
-  , fileMode :: FileMode
+  , fileMode              :: !FileMode
-  , linkCount :: LinkCount
+  , linkCount             :: !LinkCount
-  , fileOwner :: UserID
+  , fileOwner             :: !UserID
-  , fileGroup :: GroupID
+  , fileGroup             :: !GroupID
-  , specialDeviceID :: DeviceID
+  , specialDeviceID       :: !DeviceID
-  , fileSize :: FileOffset
+  , fileSize              :: !FileOffset
-  , accessTime :: EpochTime
+  , accessTime            :: !EpochTime
-  , modificationTime :: EpochTime
+  , modificationTime      :: !EpochTime
-  , statusChangeTime :: EpochTime
+  , statusChangeTime      :: !EpochTime
-  , accessTimeHiRes :: POSIXTime
+  , accessTimeHiRes       :: !POSIXTime
-  , modificationTimeHiRes :: POSIXTime
+  , modificationTimeHiRes :: !POSIXTime
-  , statusChangeTimeHiRes :: POSIXTime
+  , statusChangeTimeHiRes :: !POSIXTime
 } deriving (Show, Eq, Ord)
 
 
@@ -337,10 +341,10 @@ readDirectoryContents :: (Path Abs -> IO a)  -- ^ fills free a variable
 readDirectoryContents ff p = do
   files <- getDirsFiles p
   fcs   <- mapM (readFile ff) files
-  return $ removeNonexistent fcs
+  return fcs
 
 
--- |A variant of `readDirectoryContents` where the third argument
+-- |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
@@ -461,19 +465,7 @@ isSocketC _        = False
 ---- IO HELPERS: ----
 
 
--- |Gets all filenames of the given directory. This excludes "." and "..".
+
-getDirsFiles :: Path Abs        -- ^ dir to read
-             -> IO [Path Abs]
-getDirsFiles p =
-  P.withAbsPath p $ \fp ->
-    rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
-    $ return
-        . catMaybes
-        .   fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
-        =<< getDirectoryContents fp
-  where
-    parseMaybe :: ByteString -> Maybe (Path Fn)
-    parseMaybe = P.parseFn
 
 
 -- |Gets all file information.
@@ -510,18 +502,6 @@ handleDT p
   = handleIOError $ \e -> return $ Failed p 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 :: [File a] -> [File a]
-removeNonexistent = filter isOkConstructor
-  where
-    isOkConstructor c = not (failed c) || isOkError c
-    isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
-
 
 ---- SYMLINK HELPERS: ----
 
@@ -535,37 +515,25 @@ isBrokenSymlink (SymLink _ _ Failed{} _) = True
 isBrokenSymlink _ = False
 
 
----- OTHER: ----
 
 
--- |Apply a function on the free variable. If there is no free variable
+---- PACKERS: ----
--- 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 = P.fpToString . 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
 
 
 -- |Pack the modification time into a string.
 packModTime :: File FileInfo
             -> String
-packModTime =
+packModTime = fromFreeVar $ epochToString . modificationTime
-  fromFreeVar
+
-    $ show . posixSecondsToUTCTime . realToFrac . 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.
@@ -599,3 +567,48 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
           | 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
+

src/HSFM/FileSystem/UtilTypes.hs

@@ -0,0 +1,84 @@
+{--
+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)
+

src/HSFM/GUI/Gtk.hs

@@ -29,6 +29,7 @@ import Data.Maybe
   )
 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
@@ -44,14 +45,13 @@ main = do
   _ <- initGUI
 
   args <- SPE.getArgs
-
-  mygui <- createMyGUI
-
-  myview <- createMyView mygui createTreeView
-
   let mdir = fromMaybe (fromJust $ P.parseAbs "/")
                        (P.parseAbs . headDef "/" $ args)
-  refreshView mygui myview (Just $ mdir)
+
+  mygui <- createMyGUI
+  _ <- newTab mygui createTreeView mdir
+
+  setGUICallbacks mygui
 
   widgetShowAll (rootWin mygui)
 

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -28,17 +28,27 @@ import Control.Concurrent.STM
   )
 import Control.Exception
   (
-    throw
+    throwIO
   )
 import Control.Monad
   (
-    void
+    forM_
-  , forM_
+  , void
+  , when
   )
 import Control.Monad.IO.Class
   (
     liftIO
   )
+import Data.ByteString
+  (
+    ByteString
+  )
+import Data.ByteString.UTF8
+  (
+    fromString
+  , toString
+  )
 import Data.Foldable
   (
     for_
@@ -50,9 +60,12 @@ import HPath
       Abs
     , Path
     )
-import HSFM.FileSystem.Errors
+import HPath.IO
-import HSFM.FileSystem.FileOperations
+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
@@ -67,6 +80,12 @@ import System.Posix.Env.ByteString
   (
     getEnv
   )
+import qualified System.Posix.Process.ByteString as SPP
+import System.Posix.Types
+  (
+    ProcessID
+  )
+
 
 
 
@@ -76,14 +95,75 @@ import System.Posix.Env.ByteString
     -----------------
 
 
--- |Set callbacks, on hotkeys, events and stuff.
+
-setCallbacks :: MyGUI -> MyView -> IO ()
+
-setCallbacks mygui myview = do
+---- 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
@@ -91,73 +171,40 @@ setCallbacks mygui myview = do
              $ (\_ -> withItems mygui myview open)
       commonGuiEvents fmv
       return ()
-  menubarCallbacks
   where
-    menubarCallbacks = do
-      -- menubar-file
-      _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
-      _ <- menubarFileOpen mygui `on` menuItemActivated $
-        liftIO $ withItems mygui myview open
-      _ <- menubarFileExecute mygui `on` menuItemActivated $
-        liftIO $ withItems mygui myview execute
-      _ <- menubarFileNew mygui `on` menuItemActivated $
-        liftIO $ newFile mygui myview
-
-      -- menubar-edit
-      _ <- menubarEditCut mygui `on` menuItemActivated $
-        liftIO $ withItems mygui myview moveInit
-      _ <- menubarEditCopy mygui `on` menuItemActivated $
-        liftIO $ withItems mygui myview copyInit
-      _ <- menubarEditRename mygui `on` menuItemActivated $
-        liftIO $ withItems mygui myview renameF
-      _ <- menubarEditPaste mygui `on` menuItemActivated $
-        liftIO $ operationFinal mygui myview
-      _ <- menubarEditDelete mygui `on` menuItemActivated $
-        liftIO $ withItems mygui myview del
-
-      -- mewnubar-view
-      _ <- menubarViewIcon mygui `on` menuItemActivated $
-        liftIO $ switchView mygui myview createIconView
-      _ <- menubarViewTree mygui `on` menuItemActivated $
-        liftIO $ switchView mygui myview createTreeView
-
-      -- menubar-help
-      _ <- menubarHelpAbout mygui `on` menuItemActivated $
-        liftIO showAboutDialog
-      return ()
     commonGuiEvents fmv = do
       let view = fmViewToContainer fmv
 
       -- GUI events
-      _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
+      _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
-
+      _ <- upViewB myview `on` buttonActivated $
-      _ <- upViewB mygui `on` buttonActivated $
            upDir mygui myview
-      _ <- homeViewB mygui `on` buttonActivated $
+      _ <- homeViewB myview `on` buttonActivated $
            goHome mygui myview
-      _ <- refreshViewB mygui `on` buttonActivated $ do
+      _ <- refreshViewB myview `on` buttonActivated $ do
            cdir <- liftIO $ getCurrentDir myview
            refreshView' mygui myview cdir
-      _ <- clearStatusBar mygui `on` buttonActivated $ do
-           popStatusbar mygui
-           writeTVarIO (operationBuffer myview) None
 
       -- key events
-      _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
-        "q"       <- fmap glibToString eventKeyName
-        liftIO mainQuit
-      _ <- view `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
-      _ <- view `on` keyPressEvent $ tryEvent $ do
+      _ <- 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
@@ -173,10 +220,23 @@ setCallbacks mygui myview = do
         [Control] <- eventModifier
         "x"       <- fmap glibToString eventKeyName
         liftIO $ withItems mygui myview moveInit
-      _ <- view `on` keyPressEvent $ tryEvent $ do
+      _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
         [Control] <- eventModifier
         "v"       <- fmap glibToString eventKeyName
-        liftIO $ operationFinal mygui myview
+        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
@@ -184,7 +244,7 @@ setCallbacks mygui myview = do
         t  <- eventTime
         case eb of
           RightButton -> do
-              _ <- liftIO $ menuPopup (rcMenu mygui)
+              _ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
                           $ Just (RightButton, t)
               -- this is just to not screw with current selection
               -- on right-click
@@ -200,25 +260,42 @@ setCallbacks mygui myview = do
                   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
-      _ <- rcFileOpen mygui `on` menuItemActivated $
+
+      -- right click menu
+      _ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
         liftIO $ withItems mygui myview open
-      _ <- rcFileExecute mygui `on` menuItemActivated $
+      _ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
         liftIO $ withItems mygui myview execute
-      _ <- rcFileNew mygui `on` menuItemActivated $
+      _ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
         liftIO $ newFile mygui myview
-      _ <- rcFileCopy mygui `on` menuItemActivated $
+      _ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
+        liftIO $ newDir mygui myview
+      _ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
         liftIO $ withItems mygui myview copyInit
-      _ <- rcFileRename mygui `on` menuItemActivated $
+      _ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
         liftIO $ withItems mygui myview renameF
-      _ <- rcFilePaste mygui `on` menuItemActivated $
+      _ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
-        liftIO $ operationFinal mygui myview
+        liftIO $ operationFinal mygui myview Nothing
-      _ <- rcFileDelete mygui `on` menuItemActivated $
+      _ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
         liftIO $ withItems mygui myview del
-      _ <- rcFileCut mygui `on` menuItemActivated $
+      _ <- (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
@@ -230,21 +307,175 @@ setCallbacks mygui myview = do
 
 
 
+
+---- 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 mygui)
+  fp <- entryGetText (urlBar myview)
   forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
-      refreshView mygui myview (Just fp')
+      whenM (canOpenDirectory fp')
+            (goDir mygui myview =<< (readFile getFileInfo $ fp'))
 
 
 goHome :: MyGUI -> MyView -> IO ()
 goHome mygui myview =  withErrorDialog $ do
   mhomedir <- getEnv "HOME"
-  refreshView mygui myview (P.parseAbs =<< mhomedir)
+  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.
@@ -253,96 +484,15 @@ open [item] mygui myview = withErrorDialog $
   case item of
     DirOrSym r -> do
       nv <- readFile getFileInfo $ path r
-      refreshView' mygui myview nv
+      goDir mygui myview nv
     r ->
-      void $ openFile r
+      void $ openFile . path $ r
 -- this throws on the first error that occurs
 open (FileLikeList fs) _ _ = withErrorDialog $
-  forM_ fs $ \f -> void $ openFile f
+  forM_ fs $ \f -> void $ openFile . path $ f
 open _ _ _ = withErrorDialog
-               . throw $ InvalidOperation
+               . throwIO $ InvalidOperation
-                         "Operation not supported on multiple files"
+                           "Operation not supported on multiple files"
-
-
--- |Execute a given file.
-execute :: [Item] -> MyGUI -> MyView -> IO ()
-execute [item] _ _ = withErrorDialog $
-  void $ executeFile item []
-execute _ _ _ = withErrorDialog
-                  . throw $ InvalidOperation
-                            "Operation not supported on multiple files"
-
-
--- |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 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 item
-del _ _ _ = withErrorDialog
-              . throw $ InvalidOperation
-                        "Operation not supported on multiple files"
-
-
--- |Initializes a file move operation.
-moveInit :: [Item] -> MyGUI -> MyView -> IO ()
-moveInit items@(_:_) mygui myview = do
-  writeTVarIO (operationBuffer myview) (FMove . MP1 . 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
-                   . throw $ InvalidOperation
-                             "No file selected!"
-
--- |Supposed to be used with 'withRows'. Initializes a file copy operation.
-copyInit :: [Item] -> MyGUI -> MyView -> IO ()
-copyInit items@(_:_) mygui myview = do
-  writeTVarIO (operationBuffer myview) (FCopy . CP1 . 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
-                   . throw $ InvalidOperation
-                             "No file selected!"
-
-
--- |Finalizes a file operation, such as copy or move.
-operationFinal :: MyGUI -> MyView -> IO ()
-operationFinal _ myview = withErrorDialog $ do
-  op <- readTVarIO (operationBuffer myview)
-  cdir <- path <$> getCurrentDir myview
-  case op of
-    FMove (MP1 s) -> do
-      let cmsg = "Really move " ++ imsg s
-                  ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
-                  ++ "\"?"
-      withConfirmationDialog cmsg . withCopyModeDialog
-        $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
-      return ()
-    FCopy (CP1 s) -> do
-      let cmsg = "Really copy " ++ imsg s
-                 ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
-                 ++ "\"?"
-      withConfirmationDialog cmsg . withCopyModeDialog
-        $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
-      return ()
-    _ -> return ()
-  where
-    imsg s = case s of
-               (item:[]) -> "\"" ++ P.fpToString (P.fromAbs item) ++ "\""
-               items     -> (show . length $ items) ++ " items"
 
 
 -- |Go up one directory and visualize it in the treeView.
@@ -350,30 +500,33 @@ upDir :: MyGUI -> MyView -> IO ()
 upDir mygui myview = withErrorDialog $ do
   cdir <- getCurrentDir myview
   nv <- goUp cdir
-  refreshView' mygui myview nv
+  goDir mygui myview nv
 
 
--- |Go up one directory and visualize it in the treeView.
+-- |Go "back" in the history.
-newFile :: MyGUI -> MyView -> IO ()
+goHistoryPrev :: MyGUI -> MyView -> IO ()
-newFile _ myview = withErrorDialog $ do
+goHistoryPrev mygui myview = do
-  mfn   <- textInputDialog "Enter file name"
+  hs <- readTVarIO (history myview)
-  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
+  case hs of
-  for_ pmfn $ \fn -> do
+    ([], _) -> return ()
-    cdir  <- getCurrentDir myview
+    (x:xs, _) -> do
-    createFile cdir fn
+      cdir <- getCurrentDir myview
+      nv <- readFile getFileInfo $ x
+      modifyTVarIO (history myview)
+        (\(_, n) -> (xs, path cdir `addHistory` n))
+      refreshView' mygui myview nv
 
 
-renameF :: [Item] -> MyGUI -> MyView -> IO ()
+-- |Go "forth" in the history.
-renameF [item] _ _ = withErrorDialog $ do
+goHistoryNext :: MyGUI -> MyView -> IO ()
-  mfn  <- textInputDialog "Enter new file name"
+goHistoryNext mygui myview = do
-  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
+  hs <- readTVarIO (history myview)
-  for_ pmfn $ \fn -> do
+  case hs of
-    let cmsg = "Really rename \"" ++ getFPasStr item
+    (_, []) -> return ()
-               ++ "\"" ++ " to \""
+    (_, x:xs) -> do
-               ++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
+      cdir <- getCurrentDir myview
-                                             P.</> fn) ++ "\"?"
+      nv <- readFile getFileInfo $ x
-    withConfirmationDialog cmsg $
+      modifyTVarIO (history myview)
-      HSFM.FileSystem.FileOperations.renameFile item fn
+        (\(p, _) -> (path cdir `addHistory` p, xs))
-renameF _ _ _ = withErrorDialog
+      refreshView' mygui myview nv
-                  . throw $ InvalidOperation
+
-                            "Operation not supported on multiple files"

src/HSFM/GUI/Gtk/Callbacks.hs-boot

@@ -22,4 +22,4 @@ module HSFM.GUI.Gtk.Callbacks where
 import HSFM.GUI.Gtk.Data
 
 
-setCallbacks :: MyGUI -> MyView -> IO ()
+setViewCallbacks :: MyGUI -> MyView -> IO ()

src/HSFM/GUI/Gtk/Callbacks/Utils.hs

@@ -0,0 +1,110 @@
+{--
+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
+

src/HSFM/GUI/Gtk/Data.hs

@@ -29,10 +29,15 @@ import Control.Concurrent.STM
   (
     TVar
   )
-import Graphics.UI.Gtk
+import Graphics.UI.Gtk hiding (MenuBar)
-import HSFM.FileSystem.FileOperations
+import HPath
+  (
+    Abs
+  , Path
+  )
 import HSFM.FileSystem.FileType
-import System.INotify.ByteString
+import HSFM.FileSystem.UtilTypes
+import System.INotify
   (
     INotify
   )
@@ -50,65 +55,96 @@ import System.INotify.ByteString
 -- runtime.
 data MyGUI = MkMyGUI {
   -- |main Window
-    rootWin  :: Window
+    rootWin :: !Window
-  , menubarFileQuit :: ImageMenuItem
+
-  , menubarFileOpen :: ImageMenuItem
+  -- widgets on the main window
-  , menubarFileExecute :: ImageMenuItem
+  , menubar        :: !MenuBar
-  , menubarFileNew :: ImageMenuItem
+  , statusBar      :: !Statusbar
-  , menubarEditCut :: ImageMenuItem
+  , clearStatusBar :: !Button
-  , menubarEditCopy :: ImageMenuItem
+  , notebook       :: !Notebook
-  , menubarEditRename :: ImageMenuItem
+
-  , menubarEditPaste :: ImageMenuItem
+  -- other
-  , menubarEditDelete :: ImageMenuItem
+  , fprop    :: !FilePropertyGrid
-  , menubarViewTree :: ImageMenuItem
+  , settings :: !(TVar FMSettings)
-  , menubarViewIcon :: ImageMenuItem
+
-  , menubarHelpAbout :: ImageMenuItem
+  , operationBuffer :: !(TVar FileOperation)
-  , rcMenu :: Menu
+}
-  , rcFileOpen :: ImageMenuItem
+
-  , rcFileExecute :: ImageMenuItem
+
-  , rcFileNew :: ImageMenuItem
+-- |This describes the contents of the current view and is separated from MyGUI,
-  , rcFileCut :: ImageMenuItem
+-- because we might want to have multiple views.
-  , rcFileCopy :: ImageMenuItem
+data MyView = MkMyView {
-  , rcFileRename :: ImageMenuItem
+    view            :: !(TVar FMView)
-  , rcFilePaste :: ImageMenuItem
+  , cwd             :: !(MVar Item)
-  , rcFileDelete :: ImageMenuItem
+  , rawModel        :: !(TVar (ListStore Item))
-  , upViewB :: Button
+  , sortedModel     :: !(TVar (TypedTreeModelSort Item))
-  , homeViewB :: Button
+  , filteredModel   :: !(TVar (TypedTreeModelFilter Item))
-  , refreshViewB :: Button
+  , inotify         :: !(MVar INotify)
-  , urlBar :: Entry
+
-  , statusBar :: Statusbar
+  -- the first part of the tuple represents the "go back"
-  , clearStatusBar :: Button
+  -- the second part the "go forth" in the history
-  , settings :: TVar FMSettings
+  , history         :: !(TVar ([Path Abs], [Path Abs]))
-  , scroll :: ScrolledWindow
+
+  -- 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
+    showHidden :: !Bool
-  , isLazy :: Bool
+  , isLazy     :: !Bool
-  , iconSize :: Int
+  , iconSize   :: !Int
 }
 
-data FMView = FMTreeView TreeView
+data FMView = FMTreeView !TreeView
-            | FMIconView IconView
+            | FMIconView !IconView
 
 type Item = File FileInfo
 
 
--- |This describes the contents of the current vie 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)
-  , operationBuffer :: TVar FileOperation
-  , inotify         :: MVar INotify
-}
-
 
 fmViewToContainer :: FMView -> Container
 fmViewToContainer (FMTreeView x) =  castToContainer . toGObject $ x
 fmViewToContainer (FMIconView x) =  castToContainer . toGObject $ x
+

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -21,11 +21,14 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.GUI.Gtk.Dialogs where
 
 
+import Control.Applicative
+  (
+    (<$>)
+  )
 import Control.Exception
   (
-    catch
+    displayException
-  , displayException
+  , throwIO
-  , throw
   , IOException
   , catches
   , Handler(..)
@@ -36,6 +39,15 @@ import Control.Monad
   , when
   , void
   )
+import Data.ByteString
+  (
+    ByteString
+  )
+import qualified Data.ByteString as BS
+import Data.ByteString.UTF8
+  (
+    fromString
+  )
 import Data.Version
   (
     showVersion
@@ -60,13 +72,28 @@ import Distribution.Verbosity
   )
 import Graphics.UI.Gtk
 import qualified HPath as P
-import HSFM.FileSystem.Errors
+import HPath.IO.Errors
-import HSFM.FileSystem.FileOperations
+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
+  )
+
+
+
+
 
 
 
@@ -104,83 +131,65 @@ showConfirmationDialog str = do
     _           -> return False
 
 
--- |Asks the user which directory copy mode he wants via dialog popup
+fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
--- and returns 'DirCopyMode'. Default is always Strict, so this allows
+fileCollisionDialog t = do
--- switching to Merge/Replace/Rename.
-showCopyModeDialog :: IO (Maybe CopyMode)
-showCopyModeDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    "Target exists, how to proceed?"
+                                    (fromString "Target \"" `BS.append`
-  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+                                     t `BS.append`
-  _ <- dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
+                                     fromString "\" exists, how to proceed?")
-  _ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
-  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 3)
+  _ <- 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 Merge)
+    ResponseUser 1 -> return (Just Overwrite)
-    ResponseUser 2 -> return (Just Replace)
+    ResponseUser 2 -> return (Just OverwriteAll)
-    ResponseUser 3 -> do
+    ResponseUser 3 -> return (Just Skip)
-      mfn   <- textInputDialog "Enter new name"
+    ResponseUser 4 -> do
+      mfn   <- textInputDialog (fromString "Enter new name") (takeFileName t)
       forM mfn $ \fn -> do
-        pfn <- P.parseFn (P.userStringToFP fn)
+        pfn <- P.parseFn (fromString fn)
         return $ Rename pfn
-    _              -> throw  UnknownDialogButton
+    _              -> throwIO UnknownDialogButton
 
 
--- |Stipped version of `showCopyModeDialog` that only allows cancelling
+renameDialog :: ByteString -> IO (Maybe FCollisonMode)
--- or Renaming.
+renameDialog t = do
-showRenameDialog :: IO (Maybe CopyMode)
-showRenameDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    "Target exists, how to proceed?"
+                                    (fromString "Target \"" `BS.append`
-  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+                                     t `BS.append`
-  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 1)
+                                     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 -> do
+    ResponseUser 1 -> return (Just Skip)
-      mfn   <- textInputDialog "Enter new name"
+    ResponseUser 2 -> do
+      mfn   <- textInputDialog (fromString "Enter new name") (takeFileName t)
       forM mfn $ \fn -> do
-        pfn <- P.parseFn (P.userStringToFP fn)
+        pfn <- P.parseFn (fromString fn)
         return $ Rename pfn
-    _              -> throw  UnknownDialogButton
+    _              -> throwIO UnknownDialogButton
-
-
--- |Attempts to run the given function with the `Strict` copy mode.
--- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
--- the user for action via `showCopyModeDialog` and then carries out
--- the given function again.
-withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
-withCopyModeDialog fa =
-  catch (fa Strict) $ \e ->
-    case e of
-      FileDoesExist _ -> doIt showCopyModeDialog
-      DirDoesExist  _ -> doIt showCopyModeDialog
-      SameFile _ _    -> doIt showRenameDialog
-      e'              -> throw e'
-  where
-    doIt getCm = do
-      mcm <- getCm
-      case mcm of
-        (Just Strict) -> return () -- don't try again
-        (Just cm)     -> fa cm
-        Nothing       -> return ()
 
 
 -- |Shows the about dialog from the help menu.
 showAboutDialog :: IO ()
 showAboutDialog = do
   ad       <- aboutDialogNew
-  lstr     <- readFile =<< getDataFileName "LICENSE"
+  lstr     <- Prelude.readFile =<< getDataFileName "LICENSE"
   hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
   pdesc    <- fmap packageDescription
                    (readPackageDescription silent
@@ -217,20 +226,24 @@ withErrorDialog io =
     [ Handler (\e -> showErrorDialog
                        $ displayException (e :: IOException))
     , Handler (\e -> showErrorDialog
-                       $ displayException (e :: FmIOException))
+                       $ displayException (e :: HPathIOException))
     ]
 
 
 -- |Asks the user which directory copy mode he wants via dialog popup
 -- and returns 'DirCopyMode'.
-textInputDialog :: String -> IO (Maybe String)
+textInputDialog :: GlibString string
-textInputDialog title = do
+                => 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)
@@ -241,6 +254,53 @@ textInputDialog title = do
            -- TODO: make this more safe
            ResponseUser 0 -> Just <$> entryGetText entry
            ResponseUser 1 -> return Nothing
-           _              -> throw  UnknownDialogButton
+           _              -> 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 ()
+

src/HSFM/GUI/Gtk/Errors.hs

@@ -16,6 +16,7 @@ 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.

src/HSFM/GUI/Gtk/Icons.hs

@@ -22,6 +22,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.GUI.Gtk.Icons where
 
 
+import Control.Applicative
+  (
+    (<$>)
+  )
 import Data.Maybe
   (
     fromJust

src/HSFM/GUI/Gtk/MyGUI.hs

@@ -16,6 +16,7 @@ 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
@@ -26,6 +27,7 @@ import Control.Concurrent.STM
     newTVarIO
   )
 import Graphics.UI.Gtk
+import HSFM.FileSystem.UtilTypes
 import HSFM.GUI.Gtk.Data
 import Paths_hsfm
   (
@@ -46,6 +48,7 @@ createMyGUI = do
 
   let settings' = MkFMSettings False True 24
   settings <- newTVarIO settings'
+  operationBuffer <- newTVarIO None
 
   builder <- builderNew
   builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
@@ -53,64 +56,38 @@ createMyGUI = do
   -- 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"
   clearStatusBar    <- builderGetObject builder castToButton
                        "clearStatusBar"
-  rcMenu            <- builderGetObject builder castToMenu
+  fpropGrid         <- builderGetObject builder castToGrid
-                       "rcMenu"
+                       "fpropGrid"
-  rcFileOpen        <- builderGetObject builder castToImageMenuItem
+  fpropFnEntry      <- builderGetObject builder castToEntry
-                       "rcFileOpen"
+                       "fpropFnEntry"
-  rcFileExecute     <- builderGetObject builder castToImageMenuItem
+  fpropLocEntry     <- builderGetObject builder castToEntry
-                       "rcFileExecute"
+                       "fpropLocEntry"
-  rcFileNew         <- builderGetObject builder castToImageMenuItem
+  fpropTsEntry      <- builderGetObject builder castToEntry
-                       "rcFileNew"
+                       "fpropTsEntry"
-  rcFileCut         <- builderGetObject builder castToImageMenuItem
+  fpropModEntry     <- builderGetObject builder castToEntry
-                       "rcFileCut"
+                       "fpropModEntry"
-  rcFileCopy        <- builderGetObject builder castToImageMenuItem
+  fpropAcEntry      <- builderGetObject builder castToEntry
-                       "rcFileCopy"
+                       "fpropAcEntry"
-  rcFileRename      <- builderGetObject builder castToImageMenuItem
+  fpropFTEntry      <- builderGetObject builder castToEntry
-                       "rcFileRename"
+                       "fpropFTEntry"
-  rcFilePaste       <- builderGetObject builder castToImageMenuItem
+  fpropPermEntry    <- builderGetObject builder castToEntry
-                       "rcFilePaste"
+                       "fpropPermEntry"
-  rcFileDelete      <- builderGetObject builder castToImageMenuItem
+  fpropLDEntry      <- builderGetObject builder castToEntry
-                       "rcFileDelete"
+                       "fpropLDEntry"
-  upViewB           <- builderGetObject builder castToButton
+  notebook          <- builderGetObject builder castToNotebook
-                       "upViewB"
+                       "notebook"
-  homeViewB         <- builderGetObject builder castToButton
-                       "homeViewB"
-  refreshViewB      <- builderGetObject builder castToButton
-                       "refreshViewB"
-  menubarViewTree   <- builderGetObject builder castToImageMenuItem
-                       "menubarViewTree"
-  menubarViewIcon   <- builderGetObject builder castToImageMenuItem
-                       "menubarViewIcon"
 
   -- construct the gui object
+  let menubar = MkMenuBar {..}
+  let fprop = MkFilePropertyGrid {..}
   let mygui  = MkMyGUI {..}
 
   -- sets the default icon

src/HSFM/GUI/Gtk/MyView.hs

@@ -16,13 +16,15 @@ 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.MyView where
 
 
+import Control.Applicative
+  (
+    (<$>)
+  )
 import Control.Concurrent.MVar
   (
     newEmptyMVar
@@ -39,6 +41,11 @@ import Control.Exception
     try
   , SomeException
   )
+import Control.Monad
+  (
+    forM_
+  )
+import qualified Data.ByteString as BS
 import Data.Foldable
   (
     for_
@@ -48,36 +55,57 @@ import Data.Maybe
     catMaybes
   , fromJust
   )
+import HPath.IO.Errors
+  (
+    canOpenDirectory
+  )
 import Graphics.UI.Gtk
-import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
+import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
 import HPath
   (
     Path
   , Abs
   )
 import qualified HPath as P
-import HSFM.FileSystem.FileOperations
 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.ByteString
+import System.INotify
   (
     addWatch
   , initINotify
   , killINotify
   , EventVariety(..)
   )
-import System.IO.Error
+import System.Posix.FilePath
   (
-    tryIOError
+    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.
@@ -85,9 +113,11 @@ createMyView :: MyGUI
              -> IO FMView
              -> IO MyView
 createMyView mygui iofmv = do
-  operationBuffer <- newTVarIO None
-
   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 []
@@ -99,14 +129,56 @@ createMyView mygui iofmv = do
   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
-  setCallbacks mygui myview
+  setViewCallbacks mygui myview
 
   -- add the treeview to the scroll container
   let oview = fmViewToContainer view'
-  containerAdd (scroll mygui) oview
+  containerAdd scroll oview
+
+  widgetShowAll viewBox
 
   return myview
 
@@ -115,22 +187,41 @@ createMyView mygui iofmv = do
 -- 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
-  let oview = fmViewToContainer view'
+  widgetDestroy (fmViewToContainer view')
+  notebookRemovePage (notebook mygui) page
 
-  widgetDestroy oview
+  return page
-
-  nview' <- iofmv
-  let nview = fmViewToContainer nview'
-
-  writeTVarIO (view myview) nview'
-
-  setCallbacks mygui myview
-
-  containerAdd (scroll mygui) nview
-  widgetShow nview
-
-  refreshView mygui myview Nothing
 
 
 -- |Createss an IconView.
@@ -156,6 +247,13 @@ createTreeView = do
   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
@@ -212,16 +310,10 @@ refreshView :: MyGUI
 refreshView mygui myview mfp =
   case mfp of
     Just fp  -> do
-      -- readFileWithFileInfo can just outright fail...
+      canopen <- canOpenDirectory fp
-      ecdir <- tryIOError (readFile getFileInfo fp)
+      if canopen
-      case ecdir of
+         then refreshView' mygui myview =<< readFile getFileInfo fp
-        Right cdir ->
+         else refreshView mygui myview =<< getAlternativeDir
-          -- ...or return an `AnchordFile` with a Failed constructor,
-          -- both of which need to be handled here
-          if (failed cdir)
-            then refreshView mygui myview =<< getAlternativeDir
-            else refreshView' mygui myview cdir
-        Left _ -> refreshView mygui myview =<< getAlternativeDir
     Nothing  -> refreshView mygui myview =<< getAlternativeDir
     where
       getAlternativeDir = do
@@ -229,7 +321,7 @@ refreshView mygui myview mfp =
                                                      Item)
         case ecd of
           Right dir -> return (Just $ path dir)
-          Left _    -> return (P.parseAbs "/")
+          Left _    -> return (P.parseAbs $ BS.singleton pathSeparator)
 
 
 -- |Refreshes the View based on the given directory.
@@ -240,14 +332,16 @@ refreshView' :: MyGUI
              -> MyView
              -> Item
              -> IO ()
-refreshView' mygui myview dt@(DirOrSym _) = do
+refreshView' mygui myview SymLink { sdest = d@Dir{} } =
-  newRawModel  <- fileListStore dt myview
+  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) dt
+  putMVar (cwd myview) item
 
   -- get selected items
   tps <- getSelectedTreePaths mygui myview
@@ -255,6 +349,12 @@ refreshView' mygui myview dt@(DirOrSym _) = do
 
   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
@@ -299,7 +399,7 @@ constructView mygui myview = do
   cdirp <- path <$> getCurrentDir myview
 
   -- update urlBar
-  entrySetText (urlBar mygui) (P.fromAbs cdirp)
+  entrySetText (urlBar myview) (P.fromAbs cdirp)
 
   rawModel' <- readTVarIO $ rawModel myview
 
@@ -311,7 +411,7 @@ constructView mygui myview = do
      item   <- treeModelGetRow rawModel' iter >>= (P.basename . path)
      if hidden
        then return True
-       else return $ not . P.hiddenFile $ item
+       else return . not . hiddenFile . P.fromRel $ item
 
   -- sorting
   sortedModel' <- treeModelSortNewWithModel filteredModel'

src/HSFM/GUI/Gtk/Utils.hs

@@ -21,6 +21,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.GUI.Gtk.Utils where
 
 
+import Control.Applicative
+  (
+    (<$>)
+  )
 import Control.Concurrent.MVar
   (
     readMVar
@@ -67,24 +71,7 @@ getSelectedItems :: MyGUI
                  -> IO [Item]
 getSelectedItems mygui myview = do
   tps   <- getSelectedTreePaths mygui myview
-  getSelectedItems' mygui myview tps
+  catMaybes <$> mapM (rawPathToItem myview) tps
-
-
-getSelectedItems' :: MyGUI
-                  -> MyView
-                  -> [TreePath]
-                  -> IO [Item]
-getSelectedItems' _ myview tps = do
-  rawModel'      <- readTVarIO $ rawModel myview
-  sortedModel'   <- readTVarIO $ sortedModel myview
-  filteredModel' <- readTVarIO $ filteredModel myview
-  iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
-  forM iters $ \iter -> do
-    cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
-    cIter  <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
-    treeModelGetRow rawModel' cIter
-
-
 
 
 -- |Carry out an action on the currently selected item.
@@ -124,13 +111,14 @@ getFirstItem myview = do
 
 
 -- |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
@@ -146,3 +134,37 @@ 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
+

src/HSFM/Utils/IO.hs

@@ -33,11 +33,6 @@ import Control.Concurrent.STM.TVar
   , modifyTVar
   , TVar
   )
-import Control.Monad
-  (
-    when
-  , unless
-  )
 
 
 -- |Atomically write a TVar.
@@ -49,14 +44,3 @@ writeTVarIO tvar val = atomically $ writeTVar tvar val
 modifyTVarIO :: TVar a -> (a -> a) -> IO ()
 modifyTVarIO tvar f = atomically $ modifyTVar tvar f
 
-
--- |If the value of the first argument is True, then execute the action
--- provided in the second argument, otherwise do nothing.
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM mb a = mb >>= (`when` a)
-
-
--- |If the value of the first argument is False, then execute the action
--- provided in the second argument, otherwise do nothing.
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM mb a = mb >>= (`unless` a)