Update .gitignore

This also touches some exception handling code, be careful.

.gitignore

@@ -7,3 +7,5 @@ cabal.sandbox.config
 *.old
 .liquid/
 3rdparty/hpath
+.stack-work/
+dist-newstyle/

.travis.yml

@@ -7,17 +7,24 @@ 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]}}
+      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
+    - env: CABALVER=2.0 GHCVER=8.2.2
+      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}
+    - env: CABALVER=2.2 GHCVER=8.4.1
+      addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1], 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
 
+env:
+  global:
+    - secure: "qAzj5tgAghFIfO6R/+Hdc5KcFhwXKNXMICNH7VLmqLzmYxk1UEkpi6hgX/f1bP5mLd07D+0IaeGFIUIWQOp+F/Du1NiX3yGbFuTt/Ja4I0K4ooCQc0w9uYLv8epxzp3VEOEI5sVCSpSomFjr7V0jwwTcBbxGUvv1VaGkJwAexRxCHuwU23KD0toECkVDsOMN/Gg2Ue/r2o+MsGx1/B9WMF0g6+zWlnrYfYZXWetl0DwATK5lZTa/21THdMrbuPX0fijGXTywvURDpCd3wIdfx9n7jPO2Gp2rcxPL/WkcIpzI211g4hEiheS+AlVyW39+C4i4MKaNK8YC+/5DRl/YHrFc7n3SZPDh+RMs6r3DS41RyRhQhz8DE0Pg4zfe/WUX4+h72TijCZ1zduh146rofwku/IGtCz5cuel+7cmTPk9ZyENYnH0ZMftkZjor9J/KamcMsN4zfaQBNJuIM3Kg8HVts3ymNIWrJ1LUn41MNt1eBDDvOWxZaHrjLyATRCFYvMr4RE01pqYKnWZ9RFfzVaYjD0QQWPWAXcCtkcAHSR6T0NxAqjLmHBNm+yWYIKG+bK2CvPNYTTNN8n4UvY1SrBpJEnLcRRns3U8nM7SVZ4GMaYzOTWtN1n0zamsl42wV0L/wqpz1SePkRZ34jca3V07XRLQSN2wjj8DyvOZUFR0="
+
 before_install:
+ - sudo apt-get install -y hscolour
  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
 
 install:
@@ -47,7 +54,13 @@ script:
    else
       echo "expected '$SRC_TGZ' not found";
       exit 1;
-   fi
+   fi;
+   cd ..
+ - sed -i -e '/hsfm,/d' hsfm.cabal
+ - cabal haddock --executables --internal --hyperlink-source --html-location=https://hackage.haskell.org/package/\$pkg-\$version/docs/
+
+after_script:
+    - ./update-gh-pages.sh
 
 notifications:
   email:

README.md

@@ -1,7 +1,8 @@
 HSFM
 ====
 
-[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](http://travis-ci.org/hasufell/hsfm)
+[![Join the chat at https://gitter.im/hasufell/hsfm](https://badges.gitter.im/hasufell/hsfm.svg)](https://gitter.im/hasufell/hsfm?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
+[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](https://travis-ci.org/hasufell/hsfm)
 
 A Gtk+:3 filemanager written in Haskell.
 
@@ -15,7 +16,7 @@ Design goals:
 Screenshots
 -----------
 
-![hsfm](https://cloud.githubusercontent.com/assets/1241845/14768900/06efd43c-0a4d-11e6-939e-6b067bdb47ce.png "hsfm-gtk")
+![hsfm](https://cloud.githubusercontent.com/assets/1241845/20034565/6c3ae80e-a3c2-11e6-882c-9fe0ff202045.png "hsfm-gtk")
 
 Installation
 ------------

data/Gtk/builder.xml

@@ -1,5 +1,5 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<!-- Generated with glade 3.18.3 -->
+<!-- Generated with glade 3.20.0 -->
 <interface>
   <requires lib="gtk+" version="3.16"/>
   <object class="GtkGrid" id="fpropGrid">
@@ -361,39 +361,123 @@
           </packing>
         </child>
         <child>
-          <object class="GtkNotebook" id="notebook">
+          <object class="GtkBox">
             <property name="visible">True</property>
-            <property name="can_focus">True</property>
+            <property name="can_focus">False</property>
-            <property name="scrollable">True</property>
             <child>
-              <placeholder/>
+              <object class="GtkPaned">
-            </child>
+                <property name="visible">True</property>
-            <child type="tab">
+                <property name="can_focus">True</property>
-              <placeholder/>
+                <child>
-            </child>
+                  <object class="GtkNotebook" id="notebook1">
-            <child>
+                    <property name="visible">True</property>
-              <placeholder/>
+                    <property name="can_focus">True</property>
-            </child>
+                    <property name="scrollable">True</property>
-            <child type="tab">
+                    <child>
-              <placeholder/>
+                      <placeholder/>
-            </child>
+                    </child>
-            <child>
+                    <child type="tab">
-              <placeholder/>
+                      <placeholder/>
-            </child>
+                    </child>
-            <child type="tab">
+                    <child>
-              <placeholder/>
+                      <placeholder/>
+                    </child>
+                    <child type="tab">
+                      <placeholder/>
+                    </child>
+                    <child>
+                      <placeholder/>
+                    </child>
+                    <child type="tab">
+                      <placeholder/>
+                    </child>
+                  </object>
+                  <packing>
+                    <property name="resize">True</property>
+                    <property name="shrink">True</property>
+                  </packing>
+                </child>
+                <child>
+                  <object class="GtkNotebook" id="notebook2">
+                    <property name="visible">True</property>
+                    <property name="can_focus">True</property>
+                    <property name="scrollable">True</property>
+                    <child>
+                      <placeholder/>
+                    </child>
+                    <child type="tab">
+                      <placeholder/>
+                    </child>
+                    <child>
+                      <placeholder/>
+                    </child>
+                    <child type="tab">
+                      <placeholder/>
+                    </child>
+                    <child>
+                      <placeholder/>
+                    </child>
+                    <child type="tab">
+                      <placeholder/>
+                    </child>
+                  </object>
+                  <packing>
+                    <property name="resize">True</property>
+                    <property name="shrink">True</property>
+                  </packing>
+                </child>
+              </object>
+              <packing>
+                <property name="expand">True</property>
+                <property name="fill">True</property>
+                <property name="position">2</property>
+              </packing>
             </child>
           </object>
           <packing>
             <property name="expand">True</property>
             <property name="fill">True</property>
-            <property name="position">2</property>
+            <property name="position">1</property>
           </packing>
         </child>
         <child>
           <object class="GtkBox" id="box3">
             <property name="visible">True</property>
             <property name="can_focus">False</property>
+            <child>
+              <object class="GtkToggleButton" id="leftNbBtn">
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="receives_default">True</property>
+                <property name="margin_left">5</property>
+                <property name="margin_right">5</property>
+                <property name="margin_top">5</property>
+                <property name="margin_bottom">5</property>
+                <property name="relief">none</property>
+                <property name="always_show_image">True</property>
+                <child>
+                  <placeholder/>
+                </child>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="position">0</property>
+              </packing>
+            </child>
+            <child>
+              <object class="GtkSeparator">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="margin_left">2</property>
+                <property name="margin_right">2</property>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="position">1</property>
+              </packing>
+            </child>
             <child>
               <object class="GtkStatusbar" id="statusBar">
                 <property name="visible">True</property>
@@ -410,7 +494,7 @@
               <packing>
                 <property name="expand">True</property>
                 <property name="fill">True</property>
-                <property name="position">0</property>
+                <property name="position">2</property>
               </packing>
             </child>
             <child>
@@ -427,14 +511,48 @@
               <packing>
                 <property name="expand">False</property>
                 <property name="fill">True</property>
-                <property name="position">1</property>
+                <property name="position">3</property>
+              </packing>
+            </child>
+            <child>
+              <object class="GtkSeparator">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="margin_left">2</property>
+                <property name="margin_right">2</property>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="position">4</property>
+              </packing>
+            </child>
+            <child>
+              <object class="GtkToggleButton" id="rightNbBtn">
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="receives_default">True</property>
+                <property name="margin_left">5</property>
+                <property name="margin_right">5</property>
+                <property name="margin_top">5</property>
+                <property name="margin_bottom">5</property>
+                <property name="relief">none</property>
+                <property name="always_show_image">True</property>
+                <child>
+                  <placeholder/>
+                </child>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="position">5</property>
               </packing>
             </child>
           </object>
           <packing>
             <property name="expand">False</property>
             <property name="fill">True</property>
-            <property name="position">3</property>
+            <property name="position">2</property>
           </packing>
         </child>
       </object>
@@ -460,6 +578,16 @@
     <property name="can_focus">False</property>
     <property name="stock">gtk-zoom-fit</property>
   </object>
+  <object class="GtkImage" id="image8">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-add</property>
+  </object>
+  <object class="GtkImage" id="image9">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="icon_name">utilities-terminal</property>
+  </object>
   <object class="GtkMenu" id="rcMenu">
     <property name="visible">True</property>
     <property name="can_focus">False</property>
@@ -510,6 +638,30 @@
                 <property name="use_stock">False</property>
               </object>
             </child>
+            <child>
+              <object class="GtkSeparatorMenuItem" id="separatormenuitem4">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+              </object>
+            </child>
+            <child>
+              <object class="GtkImageMenuItem" id="rcFileNewTab">
+                <property name="label" translatable="yes">Tab</property>
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="image">image8</property>
+                <property name="use_stock">False</property>
+              </object>
+            </child>
+            <child>
+              <object class="GtkImageMenuItem" id="rcFileNewTerm">
+                <property name="label" translatable="yes">Terminal</property>
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="image">image9</property>
+                <property name="use_stock">False</property>
+              </object>
+            </child>
           </object>
         </child>
       </object>
@@ -543,7 +695,6 @@
         <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>
@@ -614,6 +765,16 @@
       </object>
     </child>
   </object>
+  <object class="GtkImage" id="leftNbIcon">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-yes</property>
+  </object>
+  <object class="GtkImage" id="rightNbIcon">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-yes</property>
+  </object>
   <object class="GtkBox" id="viewBox">
     <property name="visible">True</property>
     <property name="can_focus">False</property>
@@ -623,24 +784,37 @@
         <property name="visible">True</property>
         <property name="can_focus">False</property>
         <child>
-          <object class="GtkEntry" id="urlBar">
+          <object class="GtkButton" id="backViewB">
             <property name="visible">True</property>
             <property name="can_focus">True</property>
-            <property name="input_purpose">url</property>
+            <property name="receives_default">True</property>
+            <child>
+              <object class="GtkImage" id="imageGoBack">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="stock">gtk-go-back</property>
+              </object>
+            </child>
           </object>
           <packing>
-            <property name="expand">True</property>
+            <property name="expand">False</property>
             <property name="fill">True</property>
+            <property name="padding">2</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>
+            <child>
+              <object class="GtkImage" id="imageGoUp">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="stock">gtk-go-up</property>
+              </object>
+            </child>
           </object>
           <packing>
             <property name="expand">False</property>
@@ -650,26 +824,37 @@
           </packing>
         </child>
         <child>
-          <object class="GtkButton" id="homeViewB">
+          <object class="GtkButton" id="forwardViewB">
-            <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>
+            <child>
+              <object class="GtkImage" id="imageGoForward">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="stock">gtk-go-forward</property>
+              </object>
+            </child>
           </object>
           <packing>
             <property name="expand">False</property>
             <property name="fill">True</property>
+            <property name="padding">2</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>
+            <child>
+              <object class="GtkImage" id="imageRefresh">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="stock">gtk-refresh</property>
+              </object>
+            </child>
           </object>
           <packing>
             <property name="expand">False</property>
@@ -678,6 +863,37 @@
             <property name="position">3</property>
           </packing>
         </child>
+        <child>
+          <object class="GtkButton" id="homeViewB">
+            <property name="visible">True</property>
+            <property name="can_focus">True</property>
+            <property name="receives_default">True</property>
+            <child>
+              <object class="GtkImage" id="imageHome">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="stock">gtk-home</property>
+              </object>
+            </child>
+          </object>
+          <packing>
+            <property name="expand">False</property>
+            <property name="fill">True</property>
+            <property name="position">4</property>
+          </packing>
+        </child>
+        <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">5</property>
+          </packing>
+        </child>
       </object>
       <packing>
         <property name="expand">False</property>
@@ -699,7 +915,7 @@
       <packing>
         <property name="expand">True</property>
         <property name="fill">True</property>
-        <property name="position">1</property>
+        <property name="position">2</property>
       </packing>
     </child>
   </object>

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.24
+cabal-version:       >=1.22
 
 data-files:
                      LICENSE
@@ -26,16 +26,18 @@ library
   exposed-modules:
                        HSFM.FileSystem.FileType
                        HSFM.FileSystem.UtilTypes
+                       HSFM.History
+                       HSFM.Settings
                        HSFM.Utils.IO
                        HSFM.Utils.MyPrelude
 
   build-depends:
                        base >= 4.8 && < 5,
                        bytestring,
-                       data-default,
                        filepath >= 1.3.0.0,
                        hinotify-bytestring,
-                       hpath >= 0.7.1,
+                       hpath >= 0.8.0,
+                       IfElse,
                        safe,
                        stm,
                        time >= 1.4.2,
@@ -53,6 +55,9 @@ library
 executable hsfm-gtk
   main-is:             HSFM/GUI/Gtk.hs
   other-modules:
+                       Paths_hsfm
+                       HSFM.FileSystem.FileType
+                       HSFM.FileSystem.UtilTypes
                        HSFM.GUI.Glib.GlibString
                        HSFM.GUI.Gtk.Callbacks
                        HSFM.GUI.Gtk.Callbacks.Utils
@@ -62,20 +67,26 @@ executable hsfm-gtk
                        HSFM.GUI.Gtk.Icons
                        HSFM.GUI.Gtk.MyGUI
                        HSFM.GUI.Gtk.MyView
+                       HSFM.GUI.Gtk.Plugins
+                       HSFM.GUI.Gtk.Settings
                        HSFM.GUI.Gtk.Utils
+                       HSFM.History
+                       HSFM.Settings
+                       HSFM.Utils.IO
                        HSFM.Utils.MyPrelude
 
   build-depends:
-                       Cabal >= 1.24.0.0,
+                       Cabal >= 1.22.0.0,
                        base >= 4.8 && < 5,
                        bytestring,
-                       data-default,
                        filepath >= 1.3.0.0,
                        glib >= 0.13,
                        gtk3 >= 0.14.1,
                        hinotify-bytestring,
-                       hpath >= 0.7.1,
+                       hpath >= 0.8.0,
                        hsfm,
+                       IfElse,
+                       monad-loops,
                        old-locale >= 1,
                        process,
                        safe,

src/HSFM/FileSystem/FileType.hs

@@ -42,7 +42,6 @@ import Data.ByteString.UTF8
   (
     toString
   )
-import Data.Default
 import Data.Time.Clock.POSIX
   (
     POSIXTime
@@ -57,13 +56,7 @@ import HPath
 import qualified HPath as P
 import HPath.IO hiding (FileType(..))
 import HPath.IO.Errors
-import HSFM.Utils.MyPrelude
 import Prelude hiding(readFile)
-import System.IO.Error
-  (
-    ioeGetErrorType
-  , isDoesNotExistErrorType
-  )
 import System.Posix.FilePath
   (
     (</>)
@@ -98,13 +91,9 @@ 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.
+-- think of.
 data File a =
-    Failed {
+  Dir {
-    path :: !(Path Abs)
-  , err  :: IOError
-  }
-  | Dir {
     path :: !(Path Abs)
   , fvar :: a
   }
@@ -115,8 +104,8 @@ data File a =
   | SymLink {
     path    :: !(Path Abs)
   , fvar    :: a
-  , sdest   :: File a  -- ^ symlink madness,
+  , sdest   :: Maybe (File a)  -- ^ symlink madness,
-                       --   we need to know where it points to
+                               --   we need to know where it points to
   , rawdest :: !ByteString
   }
   | BlockDev {
@@ -187,28 +176,31 @@ fileLike f             = (False, f)
 
 
 sdir :: File FileInfo -> (Bool, File FileInfo)
-sdir f@SymLink{ sdest = (s@SymLink{} )}
+sdir f@SymLink{ sdest = (Just s@SymLink{} )}
   -- we have to follow a chain of symlinks here, but
   -- return only the very first level
   -- TODO: this is probably obsolete now
   = case sdir s of
       (True, _) -> (True, f)
       _         -> (False, f)
-sdir f@SymLink{ sdest = Dir{} }
+sdir f@SymLink{ sdest = Just Dir{} }
   = (True, f)
 sdir f@Dir{} = (True, f)
 sdir f       = (False, f)
 
 
 -- |Matches on any non-directory kind of files, excluding symlinks.
+pattern FileLike :: File FileInfo -> File FileInfo
 pattern FileLike  f <- (fileLike  -> (True, f))
 
 -- |Matches a list of directories or symlinks pointing to directories.
+pattern DirList :: [File FileInfo] -> [File FileInfo]
 pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
                                 -> (True, fs))
 
 -- |Matches a list of any non-directory kind of files or symlinks
 -- pointing to such.
+pattern FileLikeList :: [File FileInfo] -> [File FileInfo]
 pattern FileLikeList fs <- (\fs -> (and
                                      . fmap (fst . sfileLike)
                                      $ fs, fs) -> (True, fs))
@@ -223,31 +215,33 @@ brokenSymlink f = (isBrokenSymlink f, f)
 
 
 fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
-fileLikeSym f@SymLink{ sdest = s@SymLink{} }
+fileLikeSym f@SymLink{ sdest = Just s@SymLink{} }
   = case fileLikeSym s of
       (True, _) -> (True, f)
       _         -> (False, f)
-fileLikeSym f@SymLink{ sdest = RegFile{} }   = (True, f)
+fileLikeSym f@SymLink{ sdest = Just RegFile{} }   = (True, f)
-fileLikeSym f@SymLink{ sdest = BlockDev{} }  = (True, f)
+fileLikeSym f@SymLink{ sdest = Just BlockDev{} }  = (True, f)
-fileLikeSym f@SymLink{ sdest = CharDev{} }   = (True, f)
+fileLikeSym f@SymLink{ sdest = Just CharDev{} }   = (True, f)
-fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
+fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f)
-fileLikeSym f@SymLink{ sdest = Socket{} }    = (True, f)
+fileLikeSym f@SymLink{ sdest = Just Socket{} }    = (True, f)
 fileLikeSym f                                = (False, f)
 
 
 dirSym :: File FileInfo -> (Bool, File FileInfo)
-dirSym f@SymLink{ sdest = s@SymLink{} }
+dirSym f@SymLink{ sdest = Just s@SymLink{} }
   = case dirSym s of
       (True, _) -> (True, f)
       _         -> (False, f)
-dirSym f@SymLink{ sdest = Dir{} } = (True, f)
+dirSym f@SymLink{ sdest = Just Dir{} } = (True, f)
 dirSym f = (False, f)
 
 
 -- |Matches on symlinks pointing to file-like files only.
+pattern FileLikeSym :: File FileInfo -> File FileInfo
 pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))
 
 -- |Matches on broken symbolic links.
+pattern BrokenSymlink :: File FileInfo -> File FileInfo
 pattern BrokenSymlink  f <- (brokenSymlink  -> (True, f))
 
 
@@ -255,9 +249,11 @@ pattern BrokenSymlink  f <- (brokenSymlink  -> (True, f))
 -- If the symlink is pointing to a symlink pointing to a directory, then
 -- it will return True, but also return the first element in the symlink-
 -- chain, not the last.
+pattern DirOrSym :: File FileInfo -> File FileInfo
 pattern DirOrSym  f <- (sdir  -> (True, f))
 
 -- |Matches on symlinks pointing to directories only.
+pattern DirSym :: File FileInfo -> File FileInfo
 pattern DirSym   f <- (dirSym  -> (True, f))
 
 -- |Matches on any non-directory kind of files or symlinks pointing to
@@ -265,6 +261,7 @@ pattern DirSym   f <- (dirSym  -> (True, f))
 -- If the symlink is pointing to a symlink pointing to such a file, then
 -- it will return True, but also return the first element in the symlink-
 -- chain, not the last.
+pattern FileLikeOrSym :: File FileInfo -> File FileInfo
 pattern FileLikeOrSym  f <- (sfileLike  -> (True, f))
 
 
@@ -303,11 +300,10 @@ instance Ord (File FileInfo) where
 
 -- |Reads a file or directory Path into an `AnchoredFile`, filling the free
 -- variables via the given function.
-readFile :: (Path Abs -> IO a)
+pathToFile :: (Path Abs -> IO a)
-         -> Path Abs
+           -> Path Abs
-         -> IO (File a)
+           -> IO (File a)
-readFile ff p =
+pathToFile ff p = do
-  handleDT p $ do
     fs   <- PF.getSymbolicLinkStatus (P.toFilePath p)
     fv   <- ff p
     constructFile fs fv p
@@ -317,11 +313,12 @@ readFile ff p =
           -- symlink madness, we need to make sure we save the correct
           -- File
           x <- PF.readSymbolicLink (P.fromAbs p')
-          resolvedSyml <- handleDT p' $ do
+          resolvedSyml <- handleIOError (\_ -> return Nothing) $ do
             -- watch out, we call </> from 'filepath' here, but it is safe
             let sfp = (P.fromAbs . P.dirname $ p') </> x
             rsfp <- realpath sfp
-            readFile ff =<< P.parseAbs rsfp
+            f <- pathToFile ff =<< P.parseAbs rsfp
+            return $ Just f
           return $ SymLink p' fv resolvedSyml x
       | PF.isDirectory       fs = return $ Dir       p' fv
       | PF.isRegularFile     fs = return $ RegFile   p' fv
@@ -329,8 +326,7 @@ readFile ff p =
       | PF.isCharacterDevice fs = return $ CharDev   p' fv
       | PF.isNamedPipe       fs = return $ NamedPipe p' fv
       | PF.isSocket          fs = return $ Socket    p' fv
-      | otherwise               = return $ Failed    p' (userError
+      | otherwise               = ioError $ userError "Unknown filetype!"
-                                                         "Unknown filetype!")
 
 
 -- |Get the contents of a given directory and return them as a list
@@ -340,8 +336,7 @@ readDirectoryContents :: (Path Abs -> IO a)  -- ^ fills free a variable
                       -> IO [File a]
 readDirectoryContents ff p = do
   files <- getDirsFiles p
-  fcs   <- mapM (readFile ff) files
+  mapM (pathToFile ff) files
-  return fcs
 
 
 -- |A variant of `readDirectoryContents` where the second argument
@@ -357,12 +352,12 @@ getContents _ _ = return []
 
 -- |Go up one directory in the filesystem hierarchy.
 goUp :: File FileInfo -> IO (File FileInfo)
-goUp file = readFile getFileInfo (P.dirname . path $ file)
+goUp file = pathToFile getFileInfo (P.dirname . path $ file)
 
 
 -- |Go up one directory in the filesystem hierarchy.
 goUp' :: Path Abs -> IO (File FileInfo)
-goUp' fp = readFile getFileInfo $ P.dirname fp
+goUp' fp = pathToFile getFileInfo $ P.dirname fp
 
 
 
@@ -373,28 +368,6 @@ goUp' fp = readFile getFileInfo $ P.dirname fp
 
 
 
----- HANDLING FAILURES ----
-
-
--- |True if any Failed constructors in the tree.
-anyFailed :: [File a] -> Bool
-anyFailed = not . successful
-
--- |True if there are no Failed constructors in the tree.
-successful :: [File a] -> Bool
-successful = null . failures
-
-
--- |Returns true if argument is a `Failed` constructor.
-failed :: File a -> Bool
-failed (Failed _ _) = True
-failed _            = False
-
-
--- |Returns a list of 'Failed' constructors only.
-failures :: [File a] -> [File a]
-failures = filter failed
-
 
 
 ---- ORDERING AND EQUALITY ----
@@ -402,11 +375,7 @@ failures = filter failed
 
  -- HELPER: a non-recursive comparison
 comparingConstr :: File FileInfo -> File FileInfo -> Ordering
-comparingConstr (Failed _ _)      (DirOrSym _)      = LT
-comparingConstr (Failed _ _)      (FileLikeOrSym _) = LT
-comparingConstr (FileLikeOrSym _) (Failed _ _)      = GT
 comparingConstr (FileLikeOrSym _) (DirOrSym _)      = GT
-comparingConstr (DirOrSym _)      (Failed _ _)      = GT
 comparingConstr (DirOrSym _)      (FileLikeOrSym _) = LT
  -- else compare on the names of constructors that are the same, without
  -- looking at the contents of Dir constructors:
@@ -466,8 +435,6 @@ isSocketC _        = False
 
 
 
-
-
 -- |Gets all file information.
 getFileInfo :: Path Abs -> IO FileInfo
 getFileInfo fp = do
@@ -490,17 +457,6 @@ getFileInfo fp = do
 
 
 
----- FAILURE HELPERS: ----
-
-
--- Handles an IO exception by returning a Failed constructor filled with that
--- exception. Does not handle FmIOExceptions.
-handleDT :: Path Abs
-         -> IO (File a)
-         -> IO (File a)
-handleDT p
-  = handleIOError $ \e -> return $ Failed p e
-
 
 
 ---- SYMLINK HELPERS: ----
@@ -511,7 +467,7 @@ handleDT p
 --
 -- When called on a non-symlink, returns False.
 isBrokenSymlink :: File FileInfo -> Bool
-isBrokenSymlink (SymLink _ _ Failed{} _) = True
+isBrokenSymlink (SymLink _ _ Nothing _) = True
 isBrokenSymlink _ = False
 
 
@@ -523,13 +479,13 @@ isBrokenSymlink _ = False
 -- |Pack the modification time into a string.
 packModTime :: File FileInfo
             -> String
-packModTime = fromFreeVar $ epochToString . modificationTime
+packModTime = epochToString . modificationTime . fvar
 
 
 -- |Pack the modification time into a string.
 packAccessTime :: File FileInfo
                -> String
-packAccessTime = fromFreeVar $ epochToString . accessTime
+packAccessTime = epochToString . accessTime . fvar
 
 
 epochToString :: EpochTime -> String
@@ -539,12 +495,12 @@ epochToString =  show . posixSecondsToUTCTime . realToFrac
 -- |Pack the permissions into a string, similar to what "ls -l" does.
 packPermissions :: File FileInfo
                 -> String
-packPermissions dt = fromFreeVar (pStr . fileMode) dt
+packPermissions file = (pStr . fileMode) . fvar $ file
   where
     pStr :: FileMode -> String
     pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
       where
-        typeModeStr = case dt of
+        typeModeStr = case file of
           Dir {}       -> "d"
           RegFile {}   -> "-"
           SymLink {}   -> "l"
@@ -552,7 +508,6 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
           CharDev {}   -> "c"
           NamedPipe {} -> "p"
           Socket {}    -> "s"
-          _            -> "?"
         ownerModeStr =    hasFmStr PF.ownerReadMode    "r"
                        ++ hasFmStr PF.ownerWriteMode   "w"
                        ++ hasFmStr PF.ownerExecuteMode "x"
@@ -577,7 +532,6 @@ packFileType file = case file of
   CharDev {}   -> "Char Device"
   NamedPipe {} -> "Named Pipe"
   Socket {}    -> "Socket"
-  _            -> "Unknown"
 
 
 packLinkDestination :: File a -> Maybe ByteString
@@ -591,24 +545,6 @@ packLinkDestination file = case file of
 ---- 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/GUI/Gtk.hs

@@ -29,27 +29,36 @@ import Data.Maybe
   )
 import Graphics.UI.Gtk
 import qualified HPath as P
+import HSFM.FileSystem.FileType
 import HSFM.GUI.Gtk.Callbacks
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.MyGUI
 import HSFM.GUI.Gtk.MyView
+import Prelude hiding(readFile)
 import Safe
   (
     headDef
   )
+import System.IO.Error
+  (
+    catchIOError
+  )
 import qualified System.Posix.Env.ByteString as SPE
 
 
 main :: IO ()
 main = do
-  _ <- initGUI
-
   args <- SPE.getArgs
   let mdir = fromMaybe (fromJust $ P.parseAbs "/")
                        (P.parseAbs . headDef "/" $ args)
 
+  file <- catchIOError (pathToFile getFileInfo mdir) $
+    \_ -> pathToFile getFileInfo  . fromJust $ P.parseAbs "/"
+
+  _ <- initGUI
   mygui <- createMyGUI
-  _ <- newTab mygui createTreeView mdir
+  _ <- newTab mygui (notebook1 mygui) createTreeView file (-1)
+  _ <- newTab mygui (notebook2 mygui) createTreeView file (-1)
 
   setGUICallbacks mygui
 

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -17,6 +17,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 module HSFM.GUI.Gtk.Callbacks where
@@ -32,14 +33,21 @@ import Control.Exception
   )
 import Control.Monad
   (
-    forM_
+    forM
+  , forM_
+  , join
   , void
   , when
   )
+import Control.Monad.IfElse
 import Control.Monad.IO.Class
   (
     liftIO
   )
+import Control.Monad.Loops
+  (
+    iterateUntil
+  )
 import Data.ByteString
   (
     ByteString
@@ -56,36 +64,45 @@ import Data.Foldable
 import Graphics.UI.Gtk
 import qualified HPath as P
 import HPath
-    (
+  (
-      Abs
+    fromAbs
-    , Path
+  , Abs
-    )
+  , Path
+  )
 import HPath.IO
 import HPath.IO.Errors
-import HPath.IO.Utils
 import HSFM.FileSystem.FileType
 import HSFM.FileSystem.UtilTypes
 import HSFM.GUI.Gtk.Callbacks.Utils
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Dialogs
 import HSFM.GUI.Gtk.MyView
+import HSFM.GUI.Gtk.Plugins
+import HSFM.GUI.Gtk.Settings
 import HSFM.GUI.Gtk.Utils
+import HSFM.History
+import HSFM.Settings
 import HSFM.Utils.IO
 import Prelude hiding(readFile)
 import System.Glib.UTFString
   (
     glibToString
   )
-import System.Posix.Env.ByteString
-  (
-    getEnv
-  )
 import qualified System.Posix.Process.ByteString as SPP
 import System.Posix.Types
   (
     ProcessID
   )
-
+import Control.Concurrent.MVar
+  (
+    putMVar
+  , readMVar
+  , takeMVar
+  )
+import Paths_hsfm
+  (
+    getDataFileName
+  )
 
 
 
@@ -104,6 +121,18 @@ import System.Posix.Types
 setGUICallbacks :: MyGUI -> IO ()
 setGUICallbacks mygui = do
 
+  -- notebook toggle buttons
+  _ <- leftNbBtn mygui `on` toggled $ do
+    isPressed <- toggleButtonGetActive $ leftNbBtn mygui
+    if isPressed then widgetShow $ notebook1 mygui
+                 else widgetHide $ notebook1 mygui
+
+  _ <- rightNbBtn mygui `on` toggled $ do
+    isPressed <- toggleButtonGetActive $ rightNbBtn mygui
+    if isPressed then widgetShow $ notebook2 mygui
+                 else widgetHide $ notebook2 mygui
+
+  -- statusbar
   _ <- clearStatusBar mygui `on` buttonActivated $ do
        popStatusbar mygui
        writeTVarIO (operationBuffer mygui) None
@@ -119,8 +148,8 @@ setGUICallbacks mygui = do
 
   -- key events
   _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
-    [Control] <- eventModifier
+    QuitModifier <- eventModifier
-    "q"       <- fmap glibToString eventKeyName
+    QuitKey      <- fmap glibToString eventKeyName
     liftIO mainQuit
 
   return ()
@@ -175,7 +204,45 @@ setViewCallbacks mygui myview = do
     commonGuiEvents fmv = do
       let view = fmViewToContainer fmv
 
+      -- focus events
+      _ <- notebook1 mygui `on` setFocusChild $ \w ->
+        case w of
+             Nothing -> widgetSetSensitive (leftNbIcon mygui) False
+             _       -> widgetSetSensitive (leftNbIcon mygui) True
+      _ <- notebook2 mygui `on` setFocusChild $ \w ->
+        case w of
+             Nothing -> widgetSetSensitive (rightNbIcon mygui) False
+             _       -> widgetSetSensitive (rightNbIcon mygui) True
+
       -- GUI events
+      _ <- backViewB myview `on` buttonPressEvent $ do
+        eb <- eventButton
+        t  <- eventTime
+        case eb of
+          LeftButton  -> do
+            liftIO $ void $ goHistoryBack mygui myview
+            return True
+          RightButton -> do
+            his <- liftIO $ readMVar (history myview)
+            menu <- liftIO $ mkHistoryMenuB mygui myview
+                               (backwardsHistory his)
+            _ <- liftIO $ menuPopup menu $ Just (RightButton, t)
+            return True
+          _           -> return False
+      _ <- forwardViewB myview `on` buttonPressEvent $ do
+        eb <- eventButton
+        t  <- eventTime
+        case eb of
+          LeftButton  -> do
+            liftIO $ void $ goHistoryForward mygui myview
+            return True
+          RightButton -> do
+            his <- liftIO $ readMVar (history myview)
+            menu <- liftIO $ mkHistoryMenuF mygui myview
+                               (forwardHistory his)
+            _ <- liftIO $ menuPopup menu $ Just (RightButton, t)
+            return True
+          _           -> return False
       _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
       _ <- upViewB myview `on` buttonActivated $
            upDir mygui myview
@@ -183,69 +250,68 @@ setViewCallbacks mygui myview = do
            goHome mygui myview
       _ <- refreshViewB myview `on` buttonActivated $ do
            cdir <- liftIO $ getCurrentDir myview
-           refreshView' mygui myview cdir
+           refreshView mygui myview cdir
 
       -- key events
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
+        ShowHiddenModifier <- eventModifier
-        "h"       <- fmap glibToString eventKeyName
+        ShowHiddenKey      <- fmap glibToString eventKeyName
         cdir <- liftIO $ getCurrentDir myview
         liftIO $ modifyTVarIO (settings mygui)
                               (\x -> x { showHidden = not . showHidden $ x})
-                 >> refreshView' mygui myview cdir
+                 >> refreshView mygui myview cdir
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Alt] <- eventModifier
+        UpDirModifier <- eventModifier
-        "Up"  <- fmap glibToString eventKeyName
+        UpDirKey      <- fmap glibToString eventKeyName
         liftIO $ upDir mygui myview
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Alt] <- eventModifier
+        HistoryBackModifier <- eventModifier
-        "Left"  <- fmap glibToString eventKeyName
+        HistoryBackKey      <- fmap glibToString eventKeyName
-        liftIO $ goHistoryPrev mygui myview
+        liftIO $ void $ goHistoryBack mygui myview
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Alt] <- eventModifier
+        HistoryForwardModifier <- eventModifier
-        "Right"  <- fmap glibToString eventKeyName
+        HistoryForwardKey      <- fmap glibToString eventKeyName
-        liftIO $ goHistoryNext mygui myview
+        liftIO $ void $ goHistoryForward mygui myview
       _ <- view `on` keyPressEvent $ tryEvent $ do
-        "Delete"  <- fmap glibToString eventKeyName
+        DeleteModifier <- eventModifier
+        DeleteKey      <- fmap glibToString eventKeyName
         liftIO $ withItems mygui myview del
       _ <- view `on` keyPressEvent $ tryEvent $ do
-        []            <- eventModifier
+        OpenModifier <- eventModifier
-        "Return"      <- fmap glibToString eventKeyName
+        OpenKey      <- fmap glibToString eventKeyName
         liftIO $ withItems mygui myview open
       _ <- view `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
+        CopyModifier <- eventModifier
-        "c"       <- fmap glibToString eventKeyName
+        CopyKey      <- fmap glibToString eventKeyName
         liftIO $ withItems mygui myview copyInit
       _ <- view `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
+        MoveModifier <- eventModifier
-        "x"       <- fmap glibToString eventKeyName
+        MoveKey      <- fmap glibToString eventKeyName
         liftIO $ withItems mygui myview moveInit
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
+        PasteModifier <- eventModifier
-        "v"       <- fmap glibToString eventKeyName
+        PasteKey      <- fmap glibToString eventKeyName
         liftIO $ operationFinal mygui myview Nothing
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
+        NewTabModifier <- eventModifier
-        "t"       <- fmap glibToString eventKeyName
+        NewTabKey      <- fmap glibToString eventKeyName
-        liftIO $ void $ do
+        liftIO $ void $ newTab' mygui myview
-          cwd <- getCurrentDir myview
-          newTab mygui createTreeView (path cwd)
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        [Control] <- eventModifier
+        CloseTabModifier <- eventModifier
-        "w"       <- fmap glibToString eventKeyName
+        CloseTabKey      <- fmap glibToString eventKeyName
         liftIO $ void $ closeTab mygui myview
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
-        "F4"       <- fmap glibToString eventKeyName
+        OpenTerminalModifier <- eventModifier
+        OpenTerminalKey      <- fmap glibToString eventKeyName
         liftIO $ void $ openTerminalHere myview
 
-      -- righ-click
+      -- mouse button click
       _ <- view `on` buttonPressEvent $ do
         eb <- eventButton
         t  <- eventTime
         case eb of
           RightButton -> do
-              _ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
+              _ <- liftIO $ showPopup mygui myview t
-                          $ Just (RightButton, t)
               -- this is just to not screw with current selection
               -- on right-click
               -- TODO: this misbehaves under IconView
@@ -260,42 +326,32 @@ setViewCallbacks mygui myview = do
                   return $ elem tp selectedTps
                 -- no item under the cursor, pass on the signal
                 Nothing -> return False
+          MiddleButton -> do
+            (x, y) <- eventCoordinates
+            mitem  <- liftIO $ (getPathAtPos fmv (x, y))
+                               >>= \mpos -> fmap join
+                                 $ forM mpos (rawPathToItem myview)
+
+            case mitem of
+              -- item under the cursor, only pass on the signal
+              -- if the item under the cursor is not within the current
+              -- selection
+              (Just item) -> do
+                liftIO $ opeInNewTab mygui myview item
+                return True
+              -- no item under the cursor, pass on the signal
+              Nothing -> return False
+
           OtherButton 8 -> do
-            liftIO $ goHistoryPrev mygui myview
+            liftIO $ void $ goHistoryBack mygui myview
             return False
           OtherButton 9 -> do
-            liftIO $ goHistoryNext mygui myview
+            liftIO $ void $ goHistoryForward mygui myview
             return False
           -- not right-click, so pass on the signal
           _ -> return False
 
-      -- right click menu
-      _ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview open
-      _ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview execute
-      _ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
-        liftIO $ newFile mygui myview
-      _ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
-        liftIO $ newDir mygui myview
-      _ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview copyInit
-      _ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview renameF
-      _ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
-        liftIO $ operationFinal mygui myview Nothing
-      _ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview del
-      _ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview showFilePropertyDialog
-      _ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
-        liftIO $ withItems mygui myview moveInit
-      _ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
-        liftIO $ switchView mygui myview createIconView
-      _ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
-        liftIO $ switchView mygui myview createTreeView
       return ()
-
     getPathAtPos fmv (x, y) =
       case fmv of
         FMTreeView treeView -> do
@@ -314,8 +370,7 @@ setViewCallbacks mygui myview = do
 openTerminalHere :: MyView -> IO ProcessID
 openTerminalHere myview = do
   cwd <- (P.fromAbs . path) <$> getCurrentDir myview
-  -- TODO: make terminal configurable
+  SPP.forkProcess $ terminalCommand cwd
-  SPP.forkProcess $ SPP.executeFile "sakura" True ["-d", cwd] Nothing
 
 
 
@@ -325,9 +380,23 @@ openTerminalHere myview = do
 
 -- |Closes the current tab, but only if there is more than one tab.
 closeTab :: MyGUI -> MyView -> IO ()
-closeTab mygui myview = do
+closeTab _ myview = do
-  n <- notebookGetNPages (notebook mygui)
+  n <- notebookGetNPages (notebook myview)
-  when (n > 1) $ void $ destroyView mygui myview
+  when (n > 1) $ void $ destroyView myview
+
+
+newTab' :: MyGUI -> MyView -> IO ()
+newTab' mygui myview = do
+  cwd <- getCurrentDir myview
+  void $ withErrorDialog
+       $ newTab mygui (notebook myview) createTreeView cwd (-1)
+
+
+opeInNewTab :: MyGUI -> MyView -> Item -> IO ()
+opeInNewTab mygui myview item@(DirOrSym _) =
+  void $ withErrorDialog
+       $ newTab mygui (notebook myview) createTreeView item (-1)
+opeInNewTab _ _ _ = return ()
 
 
 
@@ -346,7 +415,7 @@ del items@(_:_) _ _ = withErrorDialog $ do
   withConfirmationDialog cmsg
     $ forM_ items $ \item -> easyDelete . path $ item
 del _ _ _ = withErrorDialog
-              . throwIO $ InvalidOperation
+              . ioError $ userError
                           "Operation not supported on multiple files"
 
 
@@ -361,7 +430,7 @@ moveInit items@(_:_) mygui _ = do
   popStatusbar mygui
   void $ pushStatusBar mygui sbmsg
 moveInit _ _ _ = withErrorDialog
-                   . throwIO $ InvalidOperation
+                   . ioError $ userError
                                "No file selected!"
 
 -- |Supposed to be used with 'withRows'. Initializes a file copy operation.
@@ -375,7 +444,7 @@ copyInit items@(_:_) mygui _ = do
   popStatusbar mygui
   void $ pushStatusBar mygui sbmsg
 copyInit _ _ _ = withErrorDialog
-                   . throwIO $ InvalidOperation
+                   . ioError $ userError
                                "No file selected!"
 
 
@@ -413,7 +482,7 @@ newFile _ myview = withErrorDialog $ do
   let pmfn = P.parseFn =<< fromString <$> mfn
   for_ pmfn $ \fn -> do
     cdir  <- getCurrentDir myview
-    createRegularFile (path cdir P.</> fn)
+    createRegularFile newFilePerms (path cdir P.</> fn)
 
 
 -- |Create a new directory.
@@ -423,7 +492,7 @@ newDir _ myview = withErrorDialog $ do
   let pmfn = P.parseFn =<< fromString <$> mfn
   for_ pmfn $ \fn -> do
     cdir  <- getCurrentDir myview
-    createDir (path cdir P.</> fn)
+    createDir newDirPerms (path cdir P.</> fn)
 
 
 renameF :: [Item] -> MyGUI -> MyView -> IO ()
@@ -440,7 +509,7 @@ renameF [item] _ _ = withErrorDialog $ do
       HPath.IO.renameFile (path item)
                           ((P.dirname $ path item) P.</> fn)
 renameF _ _ _ = withErrorDialog
-                  . throwIO $ InvalidOperation
+                  . ioError $ userError
                               "Operation not supported on multiple files"
 
 
@@ -458,15 +527,15 @@ urlGoTo mygui myview = withErrorDialog $ do
   fp <- entryGetText (urlBar myview)
   forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
       whenM (canOpenDirectory fp')
-            (goDir mygui myview =<< (readFile getFileInfo $ fp'))
+            (goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
 
 
 goHome :: MyGUI -> MyView -> IO ()
 goHome mygui myview =  withErrorDialog $ do
-  mhomedir <- getEnv "HOME"
+  homedir <- home
-  forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
+  forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' ->
       whenM (canOpenDirectory fp')
-            (goDir mygui myview =<< (readFile getFileInfo $ fp'))
+            (goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
 
 
 -- |Execute a given file.
@@ -474,7 +543,7 @@ execute :: [Item] -> MyGUI -> MyView -> IO ()
 execute [item] _ _ = withErrorDialog $
   void $ executeFile (path item) []
 execute _ _ _ = withErrorDialog
-                  . throwIO $ InvalidOperation
+                  . ioError $ userError
                               "Operation not supported on multiple files"
 
 
@@ -483,16 +552,15 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
 open [item] mygui myview = withErrorDialog $
   case item of
     DirOrSym r -> do
-      nv <- readFile getFileInfo $ path r
+      nv <- pathToFile getFileInfo $ path r
-      goDir mygui myview nv
+      goDir True mygui myview nv
     r ->
       void $ openFile . path $ r
--- this throws on the first error that occurs
+open items mygui myview = do
-open (FileLikeList fs) _ _ = withErrorDialog $
+  let dirs  = filter (fst . sdir) items
-  forM_ fs $ \f -> void $ openFile . path $ f
+      files = filter (fst . sfileLike) items
-open _ _ _ = withErrorDialog
+  forM_ dirs (withErrorDialog . opeInNewTab mygui myview)
-               . throwIO $ InvalidOperation
+  forM_ files (withErrorDialog . openFile . path)
-                           "Operation not supported on multiple files"
 
 
 -- |Go up one directory and visualize it in the treeView.
@@ -500,33 +568,162 @@ upDir :: MyGUI -> MyView -> IO ()
 upDir mygui myview = withErrorDialog $ do
   cdir <- getCurrentDir myview
   nv <- goUp cdir
-  goDir mygui myview nv
+  goDir True mygui myview nv
+
+
+
+
+---- HISTORY CALLBACKS ----
 
 
 -- |Go "back" in the history.
-goHistoryPrev :: MyGUI -> MyView -> IO ()
+goHistoryBack :: MyGUI -> MyView -> IO (Path Abs)
-goHistoryPrev mygui myview = do
+goHistoryBack mygui myview = do
-  hs <- readTVarIO (history myview)
+  hs <- takeMVar (history myview)
-  case hs of
+  let nhs = historyBack hs
-    ([], _) -> return ()
+  putMVar (history myview) nhs
-    (x:xs, _) -> do
+  nv <- pathToFile getFileInfo $ currentDir nhs
-      cdir <- getCurrentDir myview
+  goDir False mygui myview nv
-      nv <- readFile getFileInfo $ x
+  return $ currentDir nhs
-      modifyTVarIO (history myview)
-        (\(_, n) -> (xs, path cdir `addHistory` n))
-      refreshView' mygui myview nv
 
 
--- |Go "forth" in the history.
+-- |Go "forward" in the history.
-goHistoryNext :: MyGUI -> MyView -> IO ()
+goHistoryForward :: MyGUI -> MyView -> IO (Path Abs)
-goHistoryNext mygui myview = do
+goHistoryForward mygui myview = do
-  hs <- readTVarIO (history myview)
+  hs <- takeMVar (history myview)
-  case hs of
+  let nhs = historyForward hs
-    (_, []) -> return ()
+  putMVar (history myview) nhs
-    (_, x:xs) -> do
+  nv <- pathToFile getFileInfo $ currentDir nhs
-      cdir <- getCurrentDir myview
+  goDir False mygui myview nv
-      nv <- readFile getFileInfo $ x
+  return $ currentDir nhs
-      modifyTVarIO (history myview)
+
-        (\(p, _) -> (path cdir `addHistory` p, xs))
+
-      refreshView' mygui myview nv
+-- |Show backwards history in a drop-down menu, depending on the input.
+mkHistoryMenuB :: MyGUI -> MyView -> [Path Abs] -> IO Menu
+mkHistoryMenuB mygui myview hs = do
+  menu <- menuNew
+  menuitems <- forM hs $ \p -> do
+    item <- menuItemNewWithLabel (fromAbs p)
+    _ <- item `on` menuItemActivated $
+      void $ iterateUntil (== p) (goHistoryBack mygui myview)
+    return item
+  forM_ menuitems $ \item -> menuShellAppend menu item
+  widgetShowAll menu
+  return menu
+
+
+-- |Show forward history in a drop-down menu, depending on the input.
+mkHistoryMenuF :: MyGUI -> MyView -> [Path Abs] -> IO Menu
+mkHistoryMenuF mygui myview hs = do
+  menu <- menuNew
+  menuitems <- forM hs $ \p -> do
+    item <- menuItemNewWithLabel (fromAbs p)
+    _ <- item `on` menuItemActivated $
+      void $ iterateUntil (== p) (goHistoryForward mygui myview)
+    return item
+  forM_ menuitems $ \item -> menuShellAppend menu item
+  widgetShowAll menu
+  return menu
+
+
+
+
+---- RIGHTCLICK CALLBACKS ----
+
+
+-- |TODO: hopefully this does not leak
+showPopup :: MyGUI -> MyView -> TimeStamp -> IO ()
+showPopup mygui myview t
+  | null myplugins = return ()
+  | otherwise = do
+
+    rcmenu <- doRcMenu
+
+    -- add common callbacks
+    _ <- (\_ -> rcFileOpen rcmenu) myview `on` menuItemActivated $
+      liftIO $ withItems mygui myview open
+    _ <- (rcFileExecute rcmenu) `on` menuItemActivated $
+      liftIO $ withItems mygui myview execute
+    _ <- (rcFileNewRegFile rcmenu) `on` menuItemActivated $
+      liftIO $ newFile mygui myview
+    _ <- (rcFileNewDir rcmenu) `on` menuItemActivated $
+      liftIO $ newDir mygui myview
+    _ <- (rcFileNewTab rcmenu) `on` menuItemActivated $
+      liftIO $ newTab' mygui myview
+    _ <- (rcFileNewTerm rcmenu) `on` menuItemActivated $
+      liftIO $ void $ openTerminalHere myview
+    _ <- (rcFileCopy rcmenu) `on` menuItemActivated $
+      liftIO $ withItems mygui myview copyInit
+    _ <- (rcFileRename rcmenu) `on` menuItemActivated $
+      liftIO $ withItems mygui myview renameF
+    _ <- (rcFilePaste rcmenu) `on` menuItemActivated $
+      liftIO $ operationFinal mygui myview Nothing
+    _ <- (rcFileDelete rcmenu) `on` menuItemActivated $
+      liftIO $ withItems mygui myview del
+    _ <- (rcFileProperty rcmenu) `on` menuItemActivated $
+      liftIO $ withItems mygui myview showFilePropertyDialog
+    _ <- (rcFileCut rcmenu) `on` menuItemActivated $
+      liftIO $ withItems mygui myview moveInit
+    _ <- (rcFileIconView rcmenu) `on` menuItemActivated $
+      liftIO $ switchView mygui myview createIconView
+    _ <- (rcFileTreeView rcmenu) `on` menuItemActivated $
+      liftIO $ switchView mygui myview createTreeView
+
+
+    -- add another plugin separator after the existing one
+    -- where we want to place our plugins
+    sep2 <- separatorMenuItemNew
+    widgetShow sep2
+
+    menuShellInsert (rcMenu rcmenu) sep2 insertPos
+
+    plugins <- forM myplugins $ \(ma, mb, mc) -> fmap (, mb, mc) ma
+    -- need to reverse plugins list so the order is right
+    forM_ (reverse plugins) $ \(plugin, filter', cb) -> do
+      showItem <- withItems mygui myview filter'
+
+      menuShellInsert (rcMenu rcmenu) plugin insertPos
+      when showItem $ widgetShow plugin
+      -- init callback
+      plugin `on` menuItemActivated $ withItems mygui myview cb
+
+    menuPopup (rcMenu rcmenu) $ Just (RightButton, t)
+  where
+    doRcMenu = do
+      builder <- builderNew
+      builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
+
+      -- create static right-click menu
+      rcMenu            <- builderGetObject builder castToMenu
+                           (fromString "rcMenu")
+      rcFileOpen        <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileOpen")
+      rcFileExecute     <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileExecute")
+      rcFileNewRegFile  <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileNewRegFile")
+      rcFileNewDir      <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileNewDir")
+      rcFileNewTab      <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileNewTab")
+      rcFileNewTerm     <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileNewTerm")
+      rcFileCut         <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileCut")
+      rcFileCopy        <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileCopy")
+      rcFileRename      <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileRename")
+      rcFilePaste       <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFilePaste")
+      rcFileDelete      <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileDelete")
+      rcFileProperty    <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileProperty")
+      rcFileIconView    <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileIconView")
+      rcFileTreeView    <- builderGetObject builder castToImageMenuItem
+                           (fromString "rcFileTreeView")
+
+      return $ MkRightClickMenu {..}
 

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

@@ -26,12 +26,16 @@ module HSFM.GUI.Gtk.Callbacks.Utils where
 
 import Control.Monad
   (
-    forM
+    forM_
-  , forM_
+  , when
   )
-import Control.Monad.IO.Class
+import Data.Foldable
   (
-    liftIO
+    for_
+  )
+import Data.Maybe
+  (
+    fromJust
   )
 import GHC.IO.Exception
   (
@@ -42,19 +46,16 @@ import qualified HPath as P
 import HPath.IO
 import HPath.IO.Errors
 import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
+import qualified HSFM.FileSystem.UtilTypes as UT
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Dialogs
 import HSFM.GUI.Gtk.MyView
-import HSFM.GUI.Gtk.Utils
+import HSFM.History
-import HSFM.Utils.IO
-  (
-    modifyTVarIO
-  )
 import Prelude hiding(readFile)
-import Control.Concurrent.STM.TVar
+import Control.Concurrent.MVar
   (
-    readTVarIO
+    putMVar
+  , tryTakeMVar
   )
 
 
@@ -62,49 +63,67 @@ import Control.Concurrent.STM.TVar
 
 -- |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 :: UT.FileOperation -> IO ()
-doFileOperation (FCopy (Copy (f':fs') to)) =
+doFileOperation (UT.FCopy (UT.Copy (f':fs') to)) =
-  _doFileOperation (f':fs') to easyCopyOverwrite easyCopy
+  _doFileOperation (f':fs') to (\p1 p2 cm -> easyCopy p1 p2 cm FailEarly)
-    $ doFileOperation (FCopy $ Copy fs' to)
+    $ doFileOperation (UT.FCopy $ UT.Copy fs' to)
-doFileOperation (FMove (Move (f':fs') to)) =
+doFileOperation (UT.FMove (UT.Move (f':fs') to)) =
-  _doFileOperation (f':fs') to moveFileOverwrite moveFile
+  _doFileOperation (f':fs') to moveFile
-    $ doFileOperation (FMove $ Move fs' to)
+    $ doFileOperation (UT.FMove $ UT.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 -> CopyMode -> IO b)
-                 -> (P.Path b1 -> P.Path P.Abs -> IO a)
                  -> IO ()
                  -> IO ()
-_doFileOperation [] _ _ _ _ = return ()
+_doFileOperation [] _ _ _ = return ()
-_doFileOperation (f:fs) to mcOverwrite mc rest = do
+_doFileOperation (f:fs) to mc rest = do
   toname <- P.basename f
   let topath = to P.</> toname
-  reactOnError (mc f topath >> rest)
+  reactOnError (mc f topath Strict >> rest)
+    -- TODO: how safe is 'AlreadyExists' here?
     [(AlreadyExists  , collisionAction fileCollisionDialog topath)]
-    [(FileDoesExist{}, collisionAction fileCollisionDialog topath)
+    [(SameFile{}     , collisionAction renameDialog 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
+        UT.Overwrite -> mc f topath Overwrite >> rest
-        OverwriteAll -> forM_ (f:fs) $ \x -> do
+        UT.OverwriteAll -> forM_ (f:fs) $ \x -> do
                           toname' <- P.basename x
-                          mcOverwrite x (to P.</> toname')
+                          mc x (to P.</> toname') Overwrite
-        Skip         -> rest
+        UT.Skip         -> rest
-        Rename newn  -> mc f (to P.</> newn) >> rest
+        UT.Rename newn  -> mc f (to P.</> newn) Strict >> rest
         _            -> return ()
 
 
 -- |Helper that is invoked for any directory change operations.
-goDir :: MyGUI -> MyView -> Item -> IO ()
+goDir :: Bool    -- ^ whether to update the history
-goDir mygui myview item = do
+      -> MyGUI
-  cdir <- getCurrentDir myview
+      -> MyView
-  modifyTVarIO (history myview)
+      -> Item
-    (\(p, _) -> (path cdir `addHistory` p, []))
+      -> IO ()
-  refreshView' mygui myview item
+goDir bhis mygui myview item = do
+  when bhis $ do
+    mhs <- tryTakeMVar (history myview)
+    for_ mhs $ \hs -> do
+      let nhs = historyNewPath (path item) hs
+      putMVar (history myview) nhs
+  refreshView mygui myview item
+
+  -- set notebook tab label
+  page <- notebookGetCurrentPage (notebook myview)
+  child <- fromJust <$> notebookGetNthPage (notebook myview) page
+
+  -- get the label
+  ebox <- (castToEventBox . fromJust)
+    <$> notebookGetTabLabel (notebook myview) child
+  label <- (castToLabel . head) <$> containerGetChildren ebox
+
+  -- set the label
+  labelSetText label
+    (maybe (P.fromAbs $ path item)
+           P.fromRel $ P.basename . path $ item)
 

src/HSFM/GUI/Gtk/Data.hs

@@ -30,13 +30,9 @@ import Control.Concurrent.STM
     TVar
   )
 import Graphics.UI.Gtk hiding (MenuBar)
-import HPath
-  (
-    Abs
-  , Path
-  )
 import HSFM.FileSystem.FileType
 import HSFM.FileSystem.UtilTypes
+import HSFM.History
 import System.INotify
   (
     INotify
@@ -61,7 +57,14 @@ data MyGUI = MkMyGUI {
   , menubar        :: !MenuBar
   , statusBar      :: !Statusbar
   , clearStatusBar :: !Button
-  , notebook       :: !Notebook
+
+  , notebook1      :: !Notebook
+  , leftNbBtn      :: !ToggleButton
+  , leftNbIcon     :: !Image
+
+  , notebook2      :: !Notebook
+  , rightNbBtn     :: !ToggleButton
+  , rightNbIcon    :: !Image
 
   -- other
   , fprop    :: !FilePropertyGrid
@@ -80,16 +83,18 @@ data MyView = MkMyView {
   , sortedModel     :: !(TVar (TypedTreeModelSort Item))
   , filteredModel   :: !(TVar (TypedTreeModelFilter Item))
   , inotify         :: !(MVar INotify)
+  , notebook        :: !Notebook -- current notebook
 
   -- the first part of the tuple represents the "go back"
   -- the second part the "go forth" in the history
-  , history         :: !(TVar ([Path Abs], [Path Abs]))
+  , history         :: !(MVar BrowsingHistory)
 
   -- sub-widgets
   , scroll       :: !ScrolledWindow
   , viewBox      :: !Box
-  , rcmenu       :: !RightClickMenu
+  , backViewB    :: !Button
   , upViewB      :: !Button
+  , forwardViewB :: !Button
   , homeViewB    :: !Button
   , refreshViewB :: !Button
   , urlBar       :: !Entry
@@ -107,6 +112,8 @@ data RightClickMenu = MkRightClickMenu {
   , rcFileExecute    :: !ImageMenuItem
   , rcFileNewRegFile :: !ImageMenuItem
   , rcFileNewDir     :: !ImageMenuItem
+  , rcFileNewTab     :: !ImageMenuItem
+  , rcFileNewTerm    :: !ImageMenuItem
   , rcFileCut        :: !ImageMenuItem
   , rcFileCopy       :: !ImageMenuItem
   , rcFileRename     :: !ImageMenuItem

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -16,21 +16,22 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 module HSFM.GUI.Gtk.Dialogs where
 
 
-import Control.Applicative
+import Codec.Binary.UTF8.String
   (
-    (<$>)
+    decodeString
   )
 import Control.Exception
   (
-    displayException
+    catches
+  , displayException
   , throwIO
   , IOException
-  , catches
   , Handler(..)
   )
 import Control.Monad
@@ -48,23 +49,39 @@ import Data.ByteString.UTF8
   (
     fromString
   )
+import Distribution.Package
+  (
+    PackageIdentifier(..)
+  , packageVersion
+  , unPackageName
+  )
+#if MIN_VERSION_Cabal(2,0,0)
+import Distribution.Version
+  (
+    showVersion
+  )
+#else
 import Data.Version
   (
     showVersion
   )
-import Distribution.Package
+#endif
-  (
-    PackageIdentifier(..)
-  , PackageName(..)
-  )
 import Distribution.PackageDescription
   (
     GenericPackageDescription(..)
   , PackageDescription(..)
   )
+#if MIN_VERSION_Cabal(2,2,0)
+import Distribution.PackageDescription.Parsec
+#else
 import Distribution.PackageDescription.Parse
+#endif
   (
-    readPackageDescription
+#if MIN_VERSION_Cabal(2,0,0)
+    readGenericPackageDescription,
+#else
+    readPackageDescription,
+#endif
   )
 import Distribution.Verbosity
   (
@@ -97,7 +114,6 @@ import System.Posix.FilePath
 
 
 
-
     ---------------------
     --[ Dialog popups ]--
     ---------------------
@@ -192,12 +208,16 @@ showAboutDialog = do
   lstr     <- Prelude.readFile =<< getDataFileName "LICENSE"
   hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
   pdesc    <- fmap packageDescription
+#if MIN_VERSION_Cabal(2,0,0)
+                   (readGenericPackageDescription silent
+#else
                    (readPackageDescription silent
+#endif
                      =<< getDataFileName "hsfm.cabal")
   set ad
     [ aboutDialogProgramName  := (unPackageName . pkgName . package) pdesc
     , aboutDialogName         := (unPackageName . pkgName . package) pdesc
-    , aboutDialogVersion      := (showVersion . pkgVersion . package) pdesc
+    , aboutDialogVersion      := (showVersion . packageVersion . package) pdesc
     , aboutDialogCopyright    := copyright pdesc
     , aboutDialogComments     := description pdesc
     , aboutDialogLicense      := Just lstr
@@ -224,7 +244,9 @@ withErrorDialog :: IO a -> IO ()
 withErrorDialog io =
   catches (void io)
     [ Handler (\e -> showErrorDialog
-                       $ displayException (e :: IOException))
+                       . decodeString
+                       . displayException
+                       $ (e :: IOException))
     , Handler (\e -> showErrorDialog
                        $ displayException (e :: HPathIOException))
     ]
@@ -273,7 +295,7 @@ showFilePropertyDialog [item] mygui _ = do
   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 (fpropTsEntry fprop')  (show . fileSize $ fvar item)
   entrySetText (fpropModEntry fprop') (packModTime item)
   entrySetText (fpropAcEntry fprop')  (packAccessTime item)
   entrySetText (fpropFTEntry fprop')  (packFileType item)

src/HSFM/GUI/Gtk/Errors.hs

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

@@ -45,7 +45,6 @@ import Paths_hsfm
 -- |Set up the GUI. This only creates the permanent widgets.
 createMyGUI :: IO MyGUI
 createMyGUI = do
-
   let settings' = MkFMSettings False True 24
   settings <- newTVarIO settings'
   operationBuffer <- newTVarIO None
@@ -82,8 +81,32 @@ createMyGUI = do
                        "fpropPermEntry"
   fpropLDEntry      <- builderGetObject builder castToEntry
                        "fpropLDEntry"
-  notebook          <- builderGetObject builder castToNotebook
+  notebook1         <- builderGetObject builder castToNotebook
-                       "notebook"
+                       "notebook1"
+  notebook2         <- builderGetObject builder castToNotebook
+                       "notebook2"
+  leftNbIcon        <- builderGetObject builder castToImage
+                       "leftNbIcon"
+  rightNbIcon       <- builderGetObject builder castToImage
+                       "rightNbIcon"
+  leftNbBtn         <- builderGetObject builder castToToggleButton
+                       "leftNbBtn"
+  rightNbBtn        <- builderGetObject builder castToToggleButton
+                       "rightNbBtn"
+
+
+  -- this is required so that hotkeys work as expected, because
+  -- we then can connect to signals from `viewBox` more reliably
+  widgetSetCanFocus notebook1 False
+  widgetSetCanFocus notebook2 False
+
+  -- notebook toggle buttons
+  buttonSetImage leftNbBtn leftNbIcon
+  buttonSetImage rightNbBtn rightNbIcon
+  widgetSetSensitive leftNbIcon False
+  widgetSetSensitive rightNbIcon False
+  toggleButtonSetActive leftNbBtn True
+  toggleButtonSetActive rightNbBtn True
 
   -- construct the gui object
   let menubar = MkMenuBar {..}

src/HSFM/GUI/Gtk/MyView.hs

@@ -16,15 +16,12 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
+{-# LANGUAGE RecordWildCards #-}
 
 
 module HSFM.GUI.Gtk.MyView where
 
 
-import Control.Applicative
-  (
-    (<$>)
-  )
 import Control.Concurrent.MVar
   (
     newEmptyMVar
@@ -36,16 +33,16 @@ import Control.Concurrent.STM
     newTVarIO
   , readTVarIO
   )
-import Control.Exception
-  (
-    try
-  , SomeException
-  )
 import Control.Monad
   (
-    forM_
+    unless
+  , void
+  , when
+  )
+import Control.Monad.IO.Class
+  (
+    liftIO
   )
-import qualified Data.ByteString as BS
 import Data.Foldable
   (
     for_
@@ -55,23 +52,19 @@ import Data.Maybe
     catMaybes
   , fromJust
   )
-import HPath.IO.Errors
+import Data.String
   (
-    canOpenDirectory
+    fromString
   )
 import Graphics.UI.Gtk
 import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
-import HPath
-  (
-    Path
-  , Abs
-  )
 import qualified HPath as P
 import HSFM.FileSystem.FileType
 import HSFM.GUI.Glib.GlibString()
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Icons
 import HSFM.GUI.Gtk.Utils
+import HSFM.History
 import HSFM.Utils.IO
 import Paths_hsfm
   (
@@ -85,36 +78,72 @@ import System.INotify
   , killINotify
   , EventVariety(..)
   )
+import System.IO.Error
+  (
+    catchIOError
+  , ioError
+  , isUserError
+  )
 import System.Posix.FilePath
   (
-    pathSeparator
+    hiddenFile
-  , hiddenFile
   )
 
 
 
 -- |Creates a new tab with its own view and refreshes the view.
-newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
+newTab :: MyGUI -> Notebook -> IO FMView -> Item -> Int -> IO MyView
-newTab mygui iofmv path = do
+newTab mygui nb iofmv item pos = do
-  myview <- createMyView mygui iofmv
+
-  i <- notebookAppendPage (notebook mygui) (viewBox myview)
+
-       (maybe (P.fromAbs path) P.fromRel $ P.basename path)
+  -- create eventbox with label
-  mpage <- notebookGetNthPage (notebook mygui) i
+  label <- labelNewWithMnemonic
-  forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
+    (maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item)
-                                                   page
+  ebox <- eventBoxNew
-                                                   True
+  eventBoxSetVisibleWindow ebox False
-  refreshView mygui myview (Just path)
+  containerAdd ebox label
+  widgetShowAll label
+
+  myview <- createMyView mygui nb iofmv
+  _ <- notebookInsertPageMenu (notebook myview) (viewBox myview)
+    ebox ebox pos
+
+  -- set initial history
+  let historySize = 5
+  putMVar (history myview)
+          (BrowsingHistory [] (path item) [] historySize)
+
+  notebookSetTabReorderable (notebook myview) (viewBox myview) True
+
+  catchIOError (refreshView mygui myview item) $ \e -> do
+    file <- pathToFile getFileInfo . fromJust . P.parseAbs . fromString
+      $ "/"
+    refreshView mygui myview file
+    labelSetText label (fromString "/" :: String)
+    unless (isUserError e) (ioError e)
+
+  -- close callback
+  _ <- ebox `on` buttonPressEvent $ do
+    eb <- eventButton
+    case eb of
+      MiddleButton -> liftIO $ do
+        n <- notebookGetNPages (notebook myview)
+        when (n > 1) $ void $ destroyView myview
+        return True
+      _ -> return False
+
   return myview
 
 
 -- |Constructs the initial MyView object with a few dummy models.
 -- It also initializes the callbacks.
 createMyView :: MyGUI
+             -> Notebook
              -> IO FMView
              -> IO MyView
-createMyView mygui iofmv = do
+createMyView mygui nb iofmv = do
   inotify <- newEmptyMVar
-  history <- newTVarIO ([],[])
+  history <- newEmptyMVar
 
   builder <- builderNew
   builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
@@ -131,34 +160,13 @@ createMyView mygui iofmv = do
 
   urlBar            <- builderGetObject builder castToEntry
                        "urlBar"
-  rcMenu            <- builderGetObject builder castToMenu
+
-                       "rcMenu"
+  backViewB         <- builderGetObject builder castToButton
-  rcFileOpen        <- builderGetObject builder castToImageMenuItem
+                       "backViewB"
-                       "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"
+  forwardViewB      <- builderGetObject builder castToButton
+                       "forwardViewB"
   homeViewB         <- builderGetObject builder castToButton
                        "homeViewB"
   refreshViewB      <- builderGetObject builder castToButton
@@ -168,7 +176,7 @@ createMyView mygui iofmv = do
   viewBox           <- builderGetObject builder castToBox
                          "viewBox"
 
-  let rcmenu = MkRightClickMenu {..}
+  let notebook = nb
   let myview = MkMyView {..}
 
   -- set the bindings
@@ -189,37 +197,38 @@ switchView :: MyGUI -> MyView -> IO FMView -> IO ()
 switchView mygui myview iofmv = do
   cwd <- getCurrentDir myview
 
-  oldpage <- destroyView mygui myview
+  let nb = notebook myview
+
+  oldpage <- destroyView myview
 
   -- create new view and tab page where the previous one was
-  nview <- createMyView mygui iofmv
+  nview <- newTab mygui nb iofmv cwd oldpage
-  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
+  page <- fromJust <$> notebookPageNum nb (viewBox nview)
+  notebookSetCurrentPage nb page
+
+  refreshView mygui nview cwd
 
 
--- |Destroys the current view by disconnecting the watcher
+-- |Destroys the given 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 :: MyView -> IO Int
-destroyView mygui myview = do
+destroyView myview = do
   -- disconnect watcher
   mi <- tryTakeMVar (inotify myview)
   for_ mi $ \i -> killINotify i
 
-  page <- notebookGetCurrentPage (notebook mygui)
+  page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview)
 
   -- destroy old view and tab page
   view' <- readTVarIO $ view myview
   widgetDestroy (fmViewToContainer view')
-  notebookRemovePage (notebook mygui) page
+  notebookRemovePage (notebook myview) page
 
   return page
 
@@ -295,46 +304,18 @@ createTreeView = do
   return $ FMTreeView treeView
 
 
--- |Re-reads the current directory or the given one and updates the View.
--- This is more or less a wrapper around `refreshView'`
---
--- If the third argument is Nothing, it tries to re-read the current directory.
--- If that fails, it reads "/" instead.
---
--- If the third argument is (Just path) it tries to read "path". If that
--- fails, it reads "/" instead.
-refreshView :: MyGUI
-            -> MyView
-            -> Maybe (Path Abs)
-            -> IO ()
-refreshView mygui myview mfp =
-  case mfp of
-    Just fp  -> do
-      canopen <- canOpenDirectory fp
-      if canopen
-         then refreshView' mygui myview =<< readFile getFileInfo fp
-         else refreshView mygui myview =<< getAlternativeDir
-    Nothing  -> refreshView mygui myview =<< getAlternativeDir
-    where
-      getAlternativeDir = do
-        ecd <- try (getCurrentDir myview) :: IO (Either SomeException
-                                                     Item)
-        case ecd of
-          Right dir -> return (Just $ path dir)
-          Left _    -> return (P.parseAbs $ BS.singleton pathSeparator)
-
-
 -- |Refreshes the View based on the given directory.
 --
--- If the directory is not a Dir or a Symlink pointing to a Dir, then
+-- Throws:
--- calls `refreshView` with the 3rd argument being Nothing.
+--
-refreshView' :: MyGUI
+--   - `userError` on inappropriate type
+refreshView :: MyGUI
              -> MyView
              -> Item
              -> IO ()
-refreshView' mygui myview SymLink { sdest = d@Dir{} } =
+refreshView mygui myview SymLink { sdest = Just d@Dir{} } =
-  refreshView' mygui myview d
+  refreshView mygui myview d
-refreshView' mygui myview item@Dir{} = do
+refreshView mygui myview item@Dir{} = do
   newRawModel  <- fileListStore item myview
   writeTVarIO (rawModel myview) newRawModel
 
@@ -349,12 +330,6 @@ refreshView' mygui myview item@Dir{} = 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
@@ -363,8 +338,7 @@ refreshView' mygui myview item@Dir{} = do
       ntps <- mapM treeRowReferenceGetPath trs
       mapM_ (treeSelectionSelectPath tvs) ntps
     _ -> return ()
-refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
+refreshView _ _ _ = ioError $ userError "Inappropriate type!"
-refreshView' _ _ _ = return ()
 
 
 -- |Constructs the visible View with the current underlying mutable models,
@@ -389,14 +363,14 @@ constructView mygui myview = do
       dirtreePix FileLike{}      = filePix
       dirtreePix DirSym{}        = folderSymPix
       dirtreePix FileLikeSym{}   = fileSymPix
-      dirtreePix Failed{}        = errorPix
       dirtreePix BrokenSymlink{} = errorPix
       dirtreePix _               = errorPix
 
 
   view' <- readTVarIO $ view myview
 
-  cdirp <- path <$> getCurrentDir myview
+  cdir <- getCurrentDir myview
+  let cdirp = path cdir
 
   -- update urlBar
   entrySetText (urlBar myview) (P.fromAbs cdirp)
@@ -437,7 +411,7 @@ constructView mygui myview = do
   -- update model of view
   case view' of
     FMTreeView treeView -> do
-      treeViewSetModel treeView sortedModel'
+      treeViewSetModel treeView (Just sortedModel')
       treeViewSetRubberBanding treeView True
     FMIconView iconView -> do
       iconViewSetModel iconView (Just sortedModel')
@@ -454,7 +428,7 @@ constructView mygui myview = do
          newi
          [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
          (P.fromAbs cdirp)
-         (\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
+         (\_ -> postGUIAsync $ refreshView mygui myview cdir)
   putMVar (inotify myview) newi
 
   return ()

src/HSFM/GUI/Gtk/Plugins.hs

@@ -0,0 +1,112 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
+
+module HSFM.GUI.Gtk.Plugins where
+
+
+import Graphics.UI.Gtk
+import HPath
+import HSFM.FileSystem.FileType
+import HSFM.GUI.Gtk.Data
+import HSFM.GUI.Gtk.Settings
+import HSFM.GUI.Gtk.Utils
+import HSFM.Settings
+import Control.Monad
+  (
+    forM
+  , forM_
+  , void
+  )
+import System.Posix.Process.ByteString
+  (
+    executeFile
+  , forkProcess
+  )
+import Data.ByteString.UTF8
+  (
+    fromString
+  )
+import qualified Data.ByteString as BS
+
+
+
+
+
+    ---------------
+    --[ Plugins ]--
+    ---------------
+
+
+
+
+---- Global settings ----
+
+
+
+-- |Where to start inserting plugins.
+insertPos :: Int
+insertPos = 4
+
+
+-- |A list of plugins to add to the right-click menu at position
+-- `insertPos`.
+--
+-- The left part of the triple is a function that returns the menuitem.
+-- The middle part of the triple is a filter function that
+-- decides whether the item is shown.
+-- The right part of the triple is the callback, which is invoked
+-- when the menu item is clicked.
+--
+-- Plugins are added in order of this list.
+myplugins :: [(IO MenuItem
+              ,[Item] -> MyGUI -> MyView -> IO Bool
+              ,[Item] -> MyGUI -> MyView -> IO ())
+             ]
+myplugins = [(diffItem, diffFilter, diffCallback)
+            ]
+
+
+
+
+
+---- The plugins ----
+
+
+
+diffItem :: IO MenuItem
+diffItem = menuItemNewWithLabel "diff"
+
+diffFilter :: [Item] -> MyGUI -> MyView -> IO Bool
+diffFilter items _ _
+  | length items > 1 = return $ and $ fmap isFileC items
+  | otherwise        = return False
+
+diffCallback :: [Item] -> MyGUI -> MyView -> IO ()
+diffCallback items _ _ = void $
+  forkProcess $
+    executeFile
+      (fromString "meld")
+      True
+      ([fromString "--diff"] ++ fmap (fromAbs . path) items)
+      Nothing
+

src/HSFM/GUI/Gtk/Settings.hs

@@ -0,0 +1,128 @@
+{--
+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 PatternSynonyms #-}
+
+
+module HSFM.GUI.Gtk.Settings where
+
+
+import Graphics.UI.Gtk
+
+
+
+
+    --------------------
+    --[ GUI Settings ]--
+    --------------------
+
+
+
+---- Hotkey settings ----
+
+
+pattern QuitModifier :: [Modifier]
+pattern QuitModifier <- [Control]
+
+pattern QuitKey :: String
+pattern QuitKey <- "q"
+
+
+pattern ShowHiddenModifier :: [Modifier]
+pattern ShowHiddenModifier <- [Control]
+
+pattern ShowHiddenKey :: String
+pattern ShowHiddenKey <- "h"
+
+
+pattern UpDirModifier :: [Modifier]
+pattern UpDirModifier <- [Alt]
+
+pattern UpDirKey :: String
+pattern UpDirKey <- "Up"
+
+
+pattern HistoryBackModifier :: [Modifier]
+pattern HistoryBackModifier <- [Alt]
+
+pattern HistoryBackKey :: String
+pattern HistoryBackKey <- "Left"
+
+
+pattern HistoryForwardModifier :: [Modifier]
+pattern HistoryForwardModifier <- [Alt]
+
+pattern HistoryForwardKey :: String
+pattern HistoryForwardKey <- "Right"
+
+
+pattern DeleteModifier :: [Modifier]
+pattern DeleteModifier <- []
+
+pattern DeleteKey :: String
+pattern DeleteKey <- "Delete"
+
+
+pattern OpenModifier :: [Modifier]
+pattern OpenModifier <- []
+
+pattern OpenKey :: String
+pattern OpenKey <- "Return"
+
+
+pattern CopyModifier :: [Modifier]
+pattern CopyModifier <- [Control]
+
+pattern CopyKey :: String
+pattern CopyKey <- "c"
+
+
+pattern MoveModifier :: [Modifier]
+pattern MoveModifier <- [Control]
+
+pattern MoveKey :: String
+pattern MoveKey <- "x"
+
+
+pattern PasteModifier :: [Modifier]
+pattern PasteModifier <- [Control]
+
+pattern PasteKey :: String
+pattern PasteKey <- "v"
+
+
+pattern NewTabModifier :: [Modifier]
+pattern NewTabModifier <- [Control]
+
+pattern NewTabKey :: String
+pattern NewTabKey <- "t"
+
+
+pattern CloseTabModifier :: [Modifier]
+pattern CloseTabModifier <- [Control]
+
+pattern CloseTabKey :: String
+pattern CloseTabKey <- "w"
+
+
+pattern OpenTerminalModifier :: [Modifier]
+pattern OpenTerminalModifier <- []
+
+pattern OpenTerminalKey :: String
+pattern OpenTerminalKey <- "F4"
+

src/HSFM/GUI/Gtk/Utils.hs

@@ -21,10 +21,6 @@ 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
@@ -82,8 +78,8 @@ withItems :: MyGUI
           -> (   [Item]
               -> MyGUI
               -> MyView
-              -> IO ()) -- ^ action to carry out
+              -> IO a) -- ^ action to carry out
-          -> IO ()
+          -> IO a
 withItems mygui myview io = do
   items <- getSelectedItems mygui myview
   io items mygui myview
@@ -156,15 +152,3 @@ rawPathToItem myview tp = do
   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/History.hs

@@ -0,0 +1,61 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module HSFM.History where
+
+
+import HPath
+  (
+    Abs
+  , Path
+  )
+
+
+
+-- |Browsing history. For `forwardHistory` and `backwardsHistory`
+-- the first item is the most recent one.
+data BrowsingHistory = BrowsingHistory {
+    backwardsHistory :: [Path Abs]
+  , currentDir       :: Path Abs
+  , forwardHistory   :: [Path Abs]
+  , maxSize          :: Int
+}
+
+
+-- |This is meant to be called after e.g. a new path is entered
+-- (not navigated to via the history) and the history needs updating.
+historyNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory
+historyNewPath p (BrowsingHistory b cd _ s) =
+  BrowsingHistory (take s $ cd:b) p [] s
+
+
+-- |Go back one step in the history.
+historyBack :: BrowsingHistory -> BrowsingHistory
+historyBack bh@(BrowsingHistory [] _ _ _)   = bh
+historyBack (BrowsingHistory (b:bs) cd fs s) =
+  BrowsingHistory bs b (take s $ cd:fs) s
+
+
+-- |Go forward one step in the history.
+historyForward :: BrowsingHistory -> BrowsingHistory
+historyForward bh@(BrowsingHistory _ _ [] _) = bh
+historyForward (BrowsingHistory bs cd (f:fs) s) =
+  BrowsingHistory (take s $ cd:bs) f fs s
+

src/HSFM/Settings.hs

@@ -0,0 +1,67 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+
+module HSFM.Settings where
+
+
+import Data.ByteString
+  (
+    ByteString
+  )
+import Data.Maybe
+import System.Posix.Env.ByteString
+import System.Posix.Process.ByteString
+
+
+
+    -----------------------
+    --[ Common Settings ]--
+    -----------------------
+
+
+
+
+---- Command settings ----
+
+
+
+-- |The terminal command. This should call `executeFile` in the end
+-- with the appropriate arguments.
+terminalCommand :: ByteString  -- ^ current directory of the FM
+                -> IO a
+terminalCommand cwd =
+  executeFile   -- executes the given command
+    "sakura"    -- the terminal command
+    True        -- whether to search PATH
+    ["-d", cwd] -- arguments for the command
+    Nothing     -- optional custom environment: `Just [(String, String)]`
+
+
+-- |The home directory. If you want to set it explicitly, you might
+-- want to do:
+--
+-- @
+-- home = return "\/home\/wurst"
+-- @
+home :: IO ByteString
+home = fromMaybe <$> return "/" <*> getEnv "HOME"
+

src/HSFM/Utils/MyPrelude.hs

@@ -19,7 +19,6 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.Utils.MyPrelude where
 
 
-import Data.Default
 import Data.List
 
 
@@ -31,6 +30,3 @@ listIndices :: [a] -> [Int]
 listIndices = findIndices (const True)
 
 
--- |A `maybe` flavor using the `Default` class.
-maybeD :: (Default b) => (a -> b) -> Maybe a -> b
-maybeD = maybe def

stack.yaml

@@ -0,0 +1,9 @@
+resolver: lts-12.1
+
+packages:
+- .
+
+extra-deps:
+- IfElse-0.85
+- hinotify-bytestring-0.3.8.1
+- hpath-0.9.2

update-gh-pages.sh

@@ -0,0 +1,52 @@
+#!/bin/bash
+
+SOURCE_BRANCH="master"
+TARGET_BRANCH="gh-pages"
+REPO="https://${GH_TOKEN}@github.com/hasufell/hsfm"
+DOC_LOCATION="/dist/doc/html/hsfm/hsfm-gtk"
+
+
+# Pull requests and commits to other branches shouldn't try to deploy,
+# just build to verify
+if [ "$TRAVIS_PULL_REQUEST" != "false" -o "$TRAVIS_BRANCH" != "$SOURCE_BRANCH" ]; then
+    echo "Skipping docs deploy."
+    exit 0
+fi
+
+
+cd "$HOME"
+git config --global user.email "travis@travis-ci.org"
+git config --global user.name "travis-ci"
+git clone --branch=${TARGET_BRANCH} ${REPO} ${TARGET_BRANCH} || exit 1
+
+# docs
+cd ${TARGET_BRANCH} || exit 1
+echo "Removing old docs."
+rm -rf *
+echo "Adding new docs."
+cp -rf "${TRAVIS_BUILD_DIR}${DOC_LOCATION}"/* . || exit 1
+
+# If there are no changes to the compiled out (e.g. this is a README update)
+# then just bail.
+if [ -z "`git diff --exit-code`" ]; then
+    echo "No changes to the output on this push; exiting."
+    exit 0
+fi
+
+git add -- .
+
+if [[ -e ./index.html ]] ; then
+	echo "Commiting docs."
+	git commit -m "Lastest docs updated
+
+travis build: $TRAVIS_BUILD_NUMBER
+commit: $TRAVIS_COMMIT
+auto-pushed to gh-pages"
+
+	git push origin $TARGET_BRANCH
+	echo "Published docs to gh-pages."
+else
+	echo "Error: docs are empty."
+	exit 1
+fi
+