HACKING: fix links for real

This should also speed up reading.

.gitignore

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

.gitmodules

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

HACKING.md

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

README.md

@@ -12,6 +12,10 @@ Design goals:
 - type safety, runtime safety, strictness
 - simple add-on interface
 
+Screenshots
+-----------
+
+![Image missing](https://cloud.githubusercontent.com/assets/1241845/14584163/6dbef950-0439-11e6-8a6e-2352c048775e.png "hsfm-gtk")
 
 Installation
 ------------
@@ -24,4 +28,4 @@ cabal install
 Contributing
 ------------
 
-See [HACKING.md](HACKING.md).
+See [HACKING.md](hacking/HACKING.md).

data/Gtk/builder.xml

@@ -1,5 +1,5 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<!-- Generated with glade 3.19.0 -->
+<!-- Generated with glade 3.18.3 -->
 <interface>
   <requires lib="gtk+" version="3.16"/>
   <object class="GtkImage" id="image1">
@@ -94,6 +94,21 @@
     <property name="can_focus">False</property>
     <property name="stock">gtk-edit</property>
   </object>
+  <object class="GtkImage" id="image3">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-cancel</property>
+  </object>
+  <object class="GtkImage" id="image4">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-zoom-fit</property>
+  </object>
+  <object class="GtkImage" id="image5">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-zoom-fit</property>
+  </object>
   <object class="GtkApplicationWindow" id="rootWin">
     <property name="can_focus">False</property>
     <child>
@@ -224,8 +239,31 @@
               <object class="GtkMenuItem" id="menubarView">
                 <property name="visible">True</property>
                 <property name="can_focus">False</property>
-                <property name="label" translatable="yes">_View</property>
-                <property name="use_underline">True</property>
+                <property name="label" translatable="yes">View</property>
+                <child type="submenu">
+                  <object class="GtkMenu" id="menu5">
+                    <property name="visible">True</property>
+                    <property name="can_focus">False</property>
+                    <child>
+                      <object class="GtkImageMenuItem" id="menubarViewTree">
+                        <property name="label">Tree View</property>
+                        <property name="visible">True</property>
+                        <property name="can_focus">False</property>
+                        <property name="image">image4</property>
+                        <property name="use_stock">False</property>
+                      </object>
+                    </child>
+                    <child>
+                      <object class="GtkImageMenuItem" id="menubarViewIcon">
+                        <property name="label">Icon view</property>
+                        <property name="visible">True</property>
+                        <property name="can_focus">False</property>
+                        <property name="image">image5</property>
+                        <property name="use_stock">False</property>
+                      </object>
+                    </child>
+                  </object>
+                </child>
               </object>
             </child>
             <child>
@@ -275,7 +313,36 @@
               </packing>
             </child>
             <child>
-              <object class="GtkButton" id="refreshView">
+              <object class="GtkButton" id="upViewB">
+                <property name="label">gtk-go-up</property>
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="receives_default">True</property>
+                <property name="use_stock">True</property>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="padding">2</property>
+                <property name="position">1</property>
+              </packing>
+            </child>
+            <child>
+              <object class="GtkButton" id="homeViewB">
+                <property name="label">gtk-home</property>
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="receives_default">True</property>
+                <property name="use_stock">True</property>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="position">2</property>
+              </packing>
+            </child>
+            <child>
+              <object class="GtkButton" id="refreshViewB">
                 <property name="label">gtk-refresh</property>
                 <property name="visible">True</property>
                 <property name="can_focus">True</property>
@@ -285,8 +352,8 @@
               <packing>
                 <property name="expand">False</property>
                 <property name="fill">True</property>
-                <property name="padding">5</property>
-                <property name="position">1</property>
+                <property name="padding">2</property>
+                <property name="position">3</property>
               </packing>
             </child>
           </object>
@@ -314,17 +381,45 @@
           </packing>
         </child>
         <child>
-          <object class="GtkStatusbar" id="statusBar">
+          <object class="GtkBox" id="box3">
             <property name="visible">True</property>
             <property name="can_focus">False</property>
-            <property name="margin_left">10</property>
-            <property name="margin_right">10</property>
-            <property name="margin_start">10</property>
-            <property name="margin_end">10</property>
-            <property name="margin_top">6</property>
-            <property name="margin_bottom">6</property>
-            <property name="orientation">vertical</property>
-            <property name="spacing">2</property>
+            <child>
+              <object class="GtkStatusbar" id="statusBar">
+                <property name="visible">True</property>
+                <property name="can_focus">False</property>
+                <property name="margin_left">10</property>
+                <property name="margin_right">10</property>
+                <property name="margin_start">10</property>
+                <property name="margin_end">10</property>
+                <property name="margin_top">6</property>
+                <property name="margin_bottom">6</property>
+                <property name="orientation">vertical</property>
+                <property name="spacing">2</property>
+              </object>
+              <packing>
+                <property name="expand">True</property>
+                <property name="fill">True</property>
+                <property name="position">0</property>
+              </packing>
+            </child>
+            <child>
+              <object class="GtkButton" id="clearStatusBar">
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="receives_default">True</property>
+                <property name="margin_left">5</property>
+                <property name="margin_right">5</property>
+                <property name="margin_top">5</property>
+                <property name="margin_bottom">5</property>
+                <property name="image">image3</property>
+              </object>
+              <packing>
+                <property name="expand">False</property>
+                <property name="fill">True</property>
+                <property name="position">1</property>
+              </packing>
+            </child>
           </object>
           <packing>
             <property name="expand">False</property>

hacking/HACKING.md

@@ -0,0 +1,54 @@
+HACKING
+=======
+
+Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
+if you don't know yet what you want to hack on.
+
+Coding style
+------------
+
+- match the sorroundings
+- no overcomplicated pointfree style
+- normal indenting 2 whitespaces
+- just make things pretty and readable
+- use the provided [hsimport.hs](hsimport.hs)
+
+Documentation
+-------------
+
+__Everything__ must be documented. :)
+
+Hacking Guide
+-------------
+
+The main data structure for the IO related File type is in
+[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
+should be seen as a library. This is the entry point where
+[directory contents are read](./../src/HSFM/FileSystem/FileType.hs#L465)
+and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
+The File type uses a safe Path type under the hood instead of Strings,
+utilizing the [hpath](https://github.com/hasufell/hpath) library.
+
+File operations (like copy, delete etc) are defined at
+[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
+which use this File type.
+
+Only a GTK GUI is currently implemented, the entry point being
+[HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down
+to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in
+[HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs), which is sort of
+a global object for the whole window. Inside this object are
+theoretically multiple [MyView objects](./../src/HSFM/GUI/Gtk/Data.hs#L101)
+allowed which represent the actual view on the filesystem and related
+widgets, which are constructed in
+[HSFM.GUI.Gtk.MyView](./../src/HSFM/GUI/Gtk/MyView.hs). Both MyGUI and MyView
+are more or less accessible throughout the whole GTK callstack, expclicitly
+passed as parameters.
+
+For adding new GTK widgets with functionality you mostly have to touch the
+following files:
+* [builder.xml](./../data/Gtk/builder.xml): this defines the main GUI widgets which are static, use the [glade editor](http://glade.gnome.org) to add stuff
+* [HSFM.GUI.Gtk.Data](./../src/HSFM/GUI/Gtk/Data.hs): add the widget to e.g. the MyGUI type so we can access it throughout the GTK call stack
+* [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file
+* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
+

hacking/hsimport.hs

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

hsfm.cabal

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

src/Data/DirTree.hs

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

src/GUI/Gtk.hs

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

src/GUI/Gtk/Callbacks.hs

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

src/GUI/Gtk/Utils.hs

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

src/HSFM/FileSystem/Errors.hs

@@ -0,0 +1,251 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+-- |Provides error handling.
+module HSFM.FileSystem.Errors where
+
+
+import Control.Exception
+import Control.Monad
+  (
+    when
+  , forM
+  )
+import Data.ByteString
+  (
+    ByteString
+  )
+import Data.Typeable
+import Foreign.C.Error
+  (
+    getErrno
+  , Errno
+  )
+import qualified HPath as P
+import HPath
+    (
+      Abs
+    , Path
+    )
+import HSFM.Utils.IO
+import System.IO.Error
+  (
+    catchIOError
+  )
+
+import qualified System.Posix.Directory.ByteString as PFD
+import System.Posix.FilePath
+import qualified System.Posix.Files.ByteString as PF
+
+
+data FmIOException = FileDoesNotExist ByteString
+                   | DirDoesNotExist ByteString
+                   | PathNotAbsolute ByteString
+                   | FileNotExecutable ByteString
+                   | SameFile ByteString ByteString
+                   | NotAFile ByteString
+                   | NotADir ByteString
+                   | DestinationInSource ByteString ByteString
+                   | FileDoesExist ByteString
+                   | DirDoesExist ByteString
+                   | IsSymlink ByteString
+                   | InvalidOperation String
+                   | InvalidFileName
+                   | Can'tOpenDirectory ByteString
+                   | CopyFailed String
+                   | MoveFailed String
+  deriving (Typeable)
+
+
+instance Show FmIOException where
+  show (FileDoesNotExist fp) = "File does not exist:" ++ P.fpToString fp
+  show (DirDoesNotExist fp) = "Directory does not exist: "
+                              ++ P.fpToString fp
+  show (PathNotAbsolute fp) = "Path not absolute: " ++ P.fpToString fp
+  show (FileNotExecutable fp) = "File not executable: "
+                                ++ P.fpToString fp
+  show (SameFile fp1 fp2) = P.fpToString fp1
+                            ++ " and " ++ P.fpToString fp2
+                            ++ " are the same file!"
+  show (NotAFile fp) = "Not a file: " ++ P.fpToString fp
+  show (NotADir fp) = "Not a directory: " ++ P.fpToString fp
+  show (DestinationInSource fp1 fp2) = P.fpToString fp1
+                                       ++ " is contained in "
+                                       ++ P.fpToString fp2
+  show (FileDoesExist fp) = "File does exist: " ++ P.fpToString fp
+  show (DirDoesExist fp) = "Directory does exist: " ++ P.fpToString fp
+  show (IsSymlink fp) = "Is a symlink: " ++ P.fpToString fp
+  show (InvalidOperation str) = "Invalid operation: " ++ str
+  show InvalidFileName = "Invalid file name!"
+  show (Can'tOpenDirectory fp) = "Can't open directory: "
+                                 ++ P.fpToString fp
+  show (CopyFailed str) = "Copying failed: " ++ str
+  show (MoveFailed str) = "Moving failed: " ++ str
+
+
+
+instance Exception FmIOException
+
+
+
+
+    ----------------------------
+    --[ Path based functions ]--
+    ----------------------------
+
+
+throwFileDoesExist :: Path Abs -> IO ()
+throwFileDoesExist fp =
+  whenM (doesFileExist fp) (throw . FileDoesExist
+                                  . P.fromAbs $ fp)
+
+
+throwDirDoesExist :: Path Abs -> IO ()
+throwDirDoesExist fp =
+  whenM (doesDirectoryExist fp) (throw . DirDoesExist
+                                       . P.fromAbs $ fp)
+
+
+throwFileDoesNotExist :: Path Abs -> IO ()
+throwFileDoesNotExist fp =
+  whenM (doesFileExist fp) (throw . FileDoesExist
+                                  . P.fromAbs $ fp)
+
+
+throwDirDoesNotExist :: Path Abs -> IO ()
+throwDirDoesNotExist fp =
+  whenM (doesDirectoryExist fp) (throw . DirDoesExist
+                                       . P.fromAbs $ fp)
+
+
+throwSameFile :: Path Abs -- ^ will be canonicalized
+              -> Path Abs -- ^ will be canonicalized
+              -> IO ()
+throwSameFile fp1 fp2 = do
+  fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1
+  -- TODO: clean this up... if canonicalizing fp2 fails we try to
+  --       canonicalize `dirname fp2`
+  fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
+                       (\_ -> fmap P.fromAbs
+                       $ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
+                                <$> (P.canonicalizePath $ P.dirname fp2))
+  when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
+
+
+-- |Checks whether the destination directory is contained
+-- within the source directory by comparing the device+file ID of the
+-- source directory with all device+file IDs of the parent directories
+-- of the destination.
+throwDestinationInSource :: Path Abs -- ^ source dir
+                         -> Path Abs -- ^ full destination, `dirname dest`
+                                     --   must exist
+                         -> IO ()
+throwDestinationInSource source dest = do
+  source' <- P.canonicalizePath source
+  dest'   <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
+             <$> (P.canonicalizePath $ P.dirname dest)
+  dids <- forM (P.getAllParents dest') $ \p -> do
+          fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
+          return (PF.deviceID fs, PF.fileID fs)
+  sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
+              $ PF.getSymbolicLinkStatus (P.fromAbs source')
+  when (elem sid dids)
+       (throw $ DestinationInSource (P.fromAbs dest)
+                                    (P.fromAbs source))
+
+
+-- |Checks if the given file exists and is not a directory. This follows
+-- symlinks, but will return True if the symlink is broken.
+doesFileExist :: Path Abs -> IO Bool
+doesFileExist fp =
+  handleIOError (\_ -> return False) $ do
+    fp' <- fmap P.fromAbs $ P.canonicalizePath fp
+    fs  <- PF.getFileStatus fp'
+    return $ not . PF.isDirectory $ fs
+
+
+-- |Checks if the given file exists and is a directory. This follows
+-- symlinks, but will return False if the symlink is broken.
+doesDirectoryExist :: Path Abs -> IO Bool
+doesDirectoryExist fp =
+  handleIOError (\_ -> return False) $ do
+    fp' <- fmap P.fromAbs $ P.canonicalizePath fp
+    fs  <- PF.getFileStatus fp'
+    return $ PF.isDirectory fs
+
+
+-- |Checks whether the directory at the given path exists and can be
+-- opened. This invokes `openDirStream`.
+canOpenDirectory :: Path Abs -> IO Bool
+canOpenDirectory fp =
+  handleIOError (\_ -> return False) $ do
+    bracket (PFD.openDirStream . P.fromAbs $ fp)
+            PFD.closeDirStream
+            (\_ -> return ())
+    return True
+
+
+-- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given
+-- path cannot be opened.
+throwCantOpenDirectory :: Path Abs -> IO ()
+throwCantOpenDirectory fp =
+  unlessM (canOpenDirectory fp)
+          (throw . Can'tOpenDirectory . P.fromAbs $ fp)
+
+
+
+    --------------------------------
+    --[ Error handling functions ]--
+    --------------------------------
+
+
+-- |Carries out an action, then checks if there is an IOException and
+-- a specific errno. If so, then it carries out another action, otherwise
+-- it rethrows the error.
+catchErrno :: [Errno] -- ^ errno to catch
+           -> IO a    -- ^ action to try, which can raise an IOException
+           -> IO a    -- ^ action to carry out in case of an IOException and
+                      --   if errno matches
+           -> IO a
+catchErrno en a1 a2 =
+  catchIOError a1 $ \e -> do
+    errno <- getErrno
+    if errno `elem` en
+      then a2
+      else ioError e
+
+
+-- |Execute the given action and retrow IO exceptions as a new Exception
+-- that have the given errno. If errno does not match the exception is rethrown
+-- as is.
+rethrowErrnoAs :: Exception e
+               => [Errno]       -- ^ errno to catch
+               -> e             -- ^ rethrow as if errno matches
+               -> IO a          -- ^ action to try
+               -> IO a
+rethrowErrnoAs en fmex action = catchErrno en action (throw fmex)
+
+
+
+-- |Like `catchIOError`, with arguments swapped.
+handleIOError :: (IOError -> IO a) -> IO a -> IO a
+handleIOError = flip catchIOError
+

src/HSFM/FileSystem/FileOperations.hs

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

src/HSFM/FileSystem/FileType.hs

@@ -0,0 +1,601 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+-- |This module provides data types for representing directories/files
+-- and related operations on it, mostly internal stuff.
+--
+-- It doesn't allow to represent the whole filesystem, since that's only
+-- possible through IO laziness, which introduces too much internal state.
+module HSFM.FileSystem.FileType where
+
+
+
+import Data.ByteString(ByteString)
+import Data.Default
+import Data.Maybe
+  (
+    catMaybes
+  )
+import Data.Time.Clock.POSIX
+  (
+    POSIXTime
+  , posixSecondsToUTCTime
+  )
+import Data.Time()
+import Foreign.C.Error
+  (
+    eACCES
+  )
+import HPath
+  (
+    Abs
+  , Path
+  , Fn
+  )
+import qualified HPath as P
+import HSFM.FileSystem.Errors
+import HSFM.Utils.MyPrelude
+import Prelude hiding(readFile)
+import System.IO.Error
+  (
+    ioeGetErrorType
+  , isDoesNotExistErrorType
+  )
+import System.Posix.FilePath
+  (
+    (</>)
+  )
+import System.Posix.Directory.Traversals
+  (
+    getDirectoryContents
+  , realpath
+  )
+import qualified System.Posix.Files.ByteString as PF
+import System.Posix.Types
+  (
+    DeviceID
+  , EpochTime
+  , FileID
+  , FileMode
+  , FileOffset
+  , GroupID
+  , LinkCount
+  , UserID
+  )
+
+
+
+
+
+
+    ----------------------------
+    --[ BASE TYPES ]--
+    ----------------------------
+
+
+-- |The String in the path field is always a full path.
+-- The free type variable is used in the File/Dir constructor and can hold
+-- Handles, Strings representing a file's contents or anything else you can
+-- think of. We catch any IO errors in the Failed constructor. an Exception
+-- can be converted to a String with 'show'.
+data File a =
+    Failed {
+    path :: Path Abs
+  , err  :: IOError
+  }
+  | Dir {
+    path :: Path Abs
+  , fvar :: a
+  }
+  | RegFile {
+    path :: Path Abs
+  , fvar :: a
+  }
+  | SymLink {
+    path    :: Path Abs
+  , fvar    :: a
+  , sdest   :: File a  -- ^ symlink madness,
+                       --   we need to know where it points to
+  , rawdest :: ByteString
+  }
+  | BlockDev {
+    path :: Path Abs
+  , fvar :: a
+  }
+  | CharDev {
+    path :: Path Abs
+  , fvar :: a
+  }
+  | NamedPipe {
+    path :: Path Abs
+  , fvar :: a
+  }
+  | Socket {
+    path :: Path Abs
+  , fvar :: a
+  } deriving (Show, Eq)
+
+
+-- |Low-level file information.
+data FileInfo = FileInfo {
+    deviceID :: DeviceID
+  , fileID :: FileID
+  , fileMode :: FileMode
+  , linkCount :: LinkCount
+  , fileOwner :: UserID
+  , fileGroup :: GroupID
+  , specialDeviceID :: DeviceID
+  , fileSize :: FileOffset
+  , accessTime :: EpochTime
+  , modificationTime :: EpochTime
+  , statusChangeTime :: EpochTime
+  , accessTimeHiRes :: POSIXTime
+  , modificationTimeHiRes :: POSIXTime
+  , statusChangeTimeHiRes :: POSIXTime
+} deriving (Show, Eq, Ord)
+
+
+
+
+    ------------------------------------
+    --[ ViewPatterns/PatternSynonyms ]--
+    ------------------------------------
+
+
+
+
+---- Filetypes ----
+
+
+sfileLike :: File FileInfo -> (Bool, File FileInfo)
+sfileLike f@RegFile{}   = (True, f)
+sfileLike f@BlockDev{}  = (True, f)
+sfileLike f@CharDev{}   = (True, f)
+sfileLike f@NamedPipe{} = (True, f)
+sfileLike f@Socket{}    = (True, f)
+sfileLike f             = fileLikeSym f
+
+
+fileLike :: File FileInfo -> (Bool, File FileInfo)
+fileLike f@RegFile {}  = (True, f)
+fileLike f@BlockDev{}  = (True, f)
+fileLike f@CharDev{}   = (True, f)
+fileLike f@NamedPipe{} = (True, f)
+fileLike f@Socket{}    = (True, f)
+fileLike f             = (False, f)
+
+
+sdir :: File FileInfo -> (Bool, File FileInfo)
+sdir f@SymLink{ sdest = (s@SymLink{} )}
+  -- we have to follow a chain of symlinks here, but
+  -- return only the very first level
+  -- TODO: this is probably obsolete now
+  = case sdir s of
+      (True, _) -> (True, f)
+      _         -> (False, f)
+sdir f@SymLink{ sdest = Dir{} }
+  = (True, f)
+sdir f@Dir{} = (True, f)
+sdir f       = (False, f)
+
+
+-- |Matches on any non-directory kind of files, excluding symlinks.
+pattern FileLike  f <- (fileLike  -> (True, f))
+
+-- |Matches a list of directories or symlinks pointing to directories.
+pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
+                                -> (True, fs))
+
+-- |Matches a list of any non-directory kind of files or symlinks
+-- pointing to such.
+pattern FileLikeList fs <- (\fs -> (and
+                                     . fmap (fst . sfileLike)
+                                     $ fs, fs) -> (True, fs))
+
+
+
+---- Symlinks ----
+
+
+brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
+brokenSymlink f = (isBrokenSymlink f, f)
+
+
+fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
+fileLikeSym f@SymLink{ sdest = s@SymLink{} }
+  = case fileLikeSym s of
+      (True, _) -> (True, f)
+      _         -> (False, f)
+fileLikeSym f@SymLink{ sdest = RegFile{} }   = (True, f)
+fileLikeSym f@SymLink{ sdest = BlockDev{} }  = (True, f)
+fileLikeSym f@SymLink{ sdest = CharDev{} }   = (True, f)
+fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
+fileLikeSym f@SymLink{ sdest = Socket{} }    = (True, f)
+fileLikeSym f                                = (False, f)
+
+
+dirSym :: File FileInfo -> (Bool, File FileInfo)
+dirSym f@SymLink{ sdest = s@SymLink{} }
+  = case dirSym s of
+      (True, _) -> (True, f)
+      _         -> (False, f)
+dirSym f@SymLink{ sdest = Dir{} } = (True, f)
+dirSym f = (False, f)
+
+
+-- |Matches on symlinks pointing to file-like files only.
+pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))
+
+-- |Matches on broken symbolic links.
+pattern BrokenSymlink  f <- (brokenSymlink  -> (True, f))
+
+
+-- |Matches on directories or symlinks pointing to directories.
+-- If the symlink is pointing to a symlink pointing to a directory, then
+-- it will return True, but also return the first element in the symlink-
+-- chain, not the last.
+pattern DirOrSym  f <- (sdir  -> (True, f))
+
+-- |Matches on symlinks pointing to directories only.
+pattern DirSym   f <- (dirSym  -> (True, f))
+
+-- |Matches on any non-directory kind of files or symlinks pointing to
+-- such.
+-- If the symlink is pointing to a symlink pointing to such a file, then
+-- it will return True, but also return the first element in the symlink-
+-- chain, not the last.
+pattern FileLikeOrSym  f <- (sfileLike  -> (True, f))
+
+
+
+
+
+    -----------------
+    --[ INSTANCES ]--
+    -----------------
+
+
+-- | First compare constructors: Failed < Dir < File...
+-- Then compare `name`...
+-- Then compare free variable parameter of `File` constructors
+instance Ord (File FileInfo) where
+    compare (RegFile n a) (RegFile n' a') =
+        case compare n n' of
+             EQ -> compare a a'
+             el -> el
+    compare (Dir n b) (Dir n' b') =
+        case compare n n' of
+             EQ -> compare b b'
+             el -> el
+     -- after comparing above we can hand off to shape ord function:
+    compare d d' = comparingConstr d d'
+
+
+
+
+
+    ----------------------------
+    --[ HIGH LEVEL FUNCTIONS ]--
+    ----------------------------
+
+
+
+-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
+-- variables via the given function.
+readFile :: (Path Abs -> IO a)
+         -> Path Abs
+         -> IO (File a)
+readFile ff p =
+  handleDT p $ do
+    fs   <- PF.getSymbolicLinkStatus (P.toFilePath p)
+    fv   <- ff p
+    constructFile fs fv p
+  where
+    constructFile fs fv p'
+      | PF.isSymbolicLink    fs = do
+          -- symlink madness, we need to make sure we save the correct
+          -- File
+          x <- PF.readSymbolicLink (P.fromAbs p')
+          resolvedSyml <- handleDT p' $ do
+            -- watch out, we call </> from 'filepath' here, but it is safe
+            let sfp = (P.fromAbs . P.dirname $ p') </> x
+            rsfp <- realpath sfp
+            readFile ff =<< P.parseAbs rsfp
+          return $ SymLink p' fv resolvedSyml x
+      | PF.isDirectory       fs = return $ Dir       p' fv
+      | PF.isRegularFile     fs = return $ RegFile   p' fv
+      | PF.isBlockDevice     fs = return $ BlockDev  p' fv
+      | PF.isCharacterDevice fs = return $ CharDev   p' fv
+      | PF.isNamedPipe       fs = return $ NamedPipe p' fv
+      | PF.isSocket          fs = return $ Socket    p' fv
+      | otherwise               = return $ Failed    p' (userError
+                                                         "Unknown filetype!")
+
+
+-- |Get the contents of a given directory and return them as a list
+-- of `AnchoredFile`.
+readDirectoryContents :: (Path Abs -> IO a)  -- ^ fills free a variable
+                      -> Path Abs            -- ^ path to read
+                      -> IO [File a]
+readDirectoryContents ff p = do
+  files <- getDirsFiles p
+  fcs   <- mapM (readFile ff) files
+  return $ removeNonexistent fcs
+
+
+-- |A variant of `readDirectoryContents` where the third argument
+-- is a `File`. If a non-directory is passed returns an empty list.
+getContents :: (Path Abs -> IO a)
+            -> File FileInfo
+            -> IO [File a]
+getContents ff (DirOrSym af)
+  = readDirectoryContents ff (path af)
+getContents _ _ = return []
+
+
+
+-- |Go up one directory in the filesystem hierarchy.
+goUp :: File FileInfo -> IO (File FileInfo)
+goUp file = readFile getFileInfo (P.dirname . path $ file)
+
+
+-- |Go up one directory in the filesystem hierarchy.
+goUp' :: Path Abs -> IO (File FileInfo)
+goUp' fp = readFile getFileInfo $ P.dirname fp
+
+
+
+
+    -----------------
+    --[ UTILITIES ]--
+    -----------------
+
+
+
+---- HANDLING FAILURES ----
+
+
+-- |True if any Failed constructors in the tree.
+anyFailed :: [File a] -> Bool
+anyFailed = not . successful
+
+-- |True if there are no Failed constructors in the tree.
+successful :: [File a] -> Bool
+successful = null . failures
+
+
+-- |Returns true if argument is a `Failed` constructor.
+failed :: File a -> Bool
+failed (Failed _ _) = True
+failed _            = False
+
+
+-- |Returns a list of 'Failed' constructors only.
+failures :: [File a] -> [File a]
+failures = filter failed
+
+
+
+---- ORDERING AND EQUALITY ----
+
+
+ -- HELPER: a non-recursive comparison
+comparingConstr :: File FileInfo -> File FileInfo -> Ordering
+comparingConstr (Failed _ _)      (DirOrSym _)      = LT
+comparingConstr (Failed _ _)      (FileLikeOrSym _) = LT
+comparingConstr (FileLikeOrSym _) (Failed _ _)      = GT
+comparingConstr (FileLikeOrSym _) (DirOrSym _)      = GT
+comparingConstr (DirOrSym _)      (Failed _ _)      = GT
+comparingConstr (DirOrSym _)      (FileLikeOrSym _) = LT
+ -- else compare on the names of constructors that are the same, without
+ -- looking at the contents of Dir constructors:
+comparingConstr t t'  = compare (path t) (path t')
+
+
+
+
+
+
+
+    ---------------
+    --[ HELPERS ]--
+    ---------------
+
+
+---- CONSTRUCTOR IDENTIFIERS ----
+
+isFileC :: File a -> Bool
+isFileC RegFile{} = True
+isFileC _         = False
+
+
+isDirC :: File a -> Bool
+isDirC Dir{} = True
+isDirC _     = False
+
+
+isSymC :: File a -> Bool
+isSymC SymLink{} = True
+isSymC _         = False
+
+
+isBlockC :: File a -> Bool
+isBlockC BlockDev{} = True
+isBlockC _          = False
+
+
+isCharC :: File a -> Bool
+isCharC CharDev{} = True
+isCharC _         = False
+
+
+isNamedC :: File a -> Bool
+isNamedC NamedPipe{} = True
+isNamedC _           = False
+
+
+isSocketC :: File a -> Bool
+isSocketC Socket{} = True
+isSocketC _        = False
+
+
+
+
+---- IO HELPERS: ----
+
+
+-- |Gets all filenames of the given directory. This excludes "." and "..".
+getDirsFiles :: Path Abs        -- ^ dir to read
+             -> IO [Path Abs]
+getDirsFiles p =
+  P.withAbsPath p $ \fp ->
+    rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
+    $ return
+        . catMaybes
+        .   fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
+        =<< getDirectoryContents fp
+  where
+    parseMaybe :: ByteString -> Maybe (Path Fn)
+    parseMaybe = P.parseFn
+
+
+-- |Gets all file information.
+getFileInfo :: Path Abs -> IO FileInfo
+getFileInfo fp = do
+  fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
+  return $ FileInfo
+    (PF.deviceID fs)
+    (PF.fileID fs)
+    (PF.fileMode fs)
+    (PF.linkCount fs)
+    (PF.fileOwner fs)
+    (PF.fileGroup fs)
+    (PF.specialDeviceID fs)
+    (PF.fileSize fs)
+    (PF.accessTime fs)
+    (PF.modificationTime fs)
+    (PF.statusChangeTime fs)
+    (PF.accessTimeHiRes fs)
+    (PF.modificationTimeHiRes fs)
+    (PF.statusChangeTimeHiRes fs)
+
+
+
+---- FAILURE HELPERS: ----
+
+
+-- Handles an IO exception by returning a Failed constructor filled with that
+-- exception. Does not handle FmIOExceptions.
+handleDT :: Path Abs
+         -> IO (File a)
+         -> IO (File a)
+handleDT p
+  = handleIOError $ \e -> return $ Failed p e
+
+
+-- DoesNotExist errors not present at the topmost level could happen if a
+-- named file or directory is deleted after being listed by
+-- getDirectoryContents but before we can get it into memory.
+--    So we filter those errors out because the user should not see errors
+-- raised by the internal implementation of this module:
+--    This leaves the error if it exists in the top (user-supplied) level:
+removeNonexistent :: [File a] -> [File a]
+removeNonexistent = filter isOkConstructor
+  where
+    isOkConstructor c = not (failed c) || isOkError c
+    isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
+
+
+---- SYMLINK HELPERS: ----
+
+
+-- |Checks if a symlink is broken by examining the constructor of the
+-- symlink destination.
+--
+-- When called on a non-symlink, returns False.
+isBrokenSymlink :: File FileInfo -> Bool
+isBrokenSymlink (SymLink _ _ Failed{} _) = True
+isBrokenSymlink _ = False
+
+
+---- 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 = P.fpToString . P.fromAbs . path
+
+
+-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
+getFreeVar :: File a -> Maybe a
+getFreeVar (Dir _  d)         = Just d
+getFreeVar (RegFile _  d)     = Just d
+getFreeVar (SymLink _  d _ _) = Just d
+getFreeVar (BlockDev _  d)    = Just d
+getFreeVar (CharDev _  d)     = Just d
+getFreeVar (NamedPipe _  d)   = Just d
+getFreeVar (Socket _  d)      = Just d
+getFreeVar _                  = Nothing
+
+
+-- |Pack the modification time into a string.
+packModTime :: File FileInfo
+            -> String
+packModTime =
+  fromFreeVar
+    $ show . posixSecondsToUTCTime . realToFrac . modificationTime
+
+
+-- |Pack the permissions into a string, similar to what "ls -l" does.
+packPermissions :: File FileInfo
+                -> String
+packPermissions dt = fromFreeVar (pStr . fileMode) dt
+  where
+    pStr :: FileMode -> String
+    pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
+      where
+        typeModeStr = case dt of
+          Dir {}       -> "d"
+          RegFile {}   -> "-"
+          SymLink {}   -> "l"
+          BlockDev {}  -> "b"
+          CharDev {}   -> "c"
+          NamedPipe {} -> "p"
+          Socket {}    -> "s"
+          _            -> "?"
+        ownerModeStr =    hasFmStr PF.ownerReadMode    "r"
+                       ++ hasFmStr PF.ownerWriteMode   "w"
+                       ++ hasFmStr PF.ownerExecuteMode "x"
+        groupModeStr =    hasFmStr PF.groupReadMode    "r"
+                       ++ hasFmStr PF.groupWriteMode   "w"
+                       ++ hasFmStr PF.groupExecuteMode "x"
+        otherModeStr =    hasFmStr PF.otherReadMode    "r"
+                       ++ hasFmStr PF.otherWriteMode   "w"
+                       ++ hasFmStr PF.otherExecuteMode "x"
+        hasFmStr fm str
+          | hasFM fm  = str
+          | otherwise = "-"
+        hasFM fm = ffm `PF.intersectFileModes` fm == fm
+

src/HSFM/GUI/Glib/GlibString.hs

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

src/HSFM/GUI/Gtk.hs

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

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -0,0 +1,379 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module HSFM.GUI.Gtk.Callbacks where
+
+
+import Control.Concurrent.STM
+  (
+    readTVarIO
+  )
+import Control.Exception
+  (
+    throw
+  )
+import Control.Monad
+  (
+    void
+  , forM_
+  )
+import Control.Monad.IO.Class
+  (
+    liftIO
+  )
+import Data.Foldable
+  (
+    for_
+  )
+import Graphics.UI.Gtk
+import qualified HPath as P
+import HPath
+    (
+      Abs
+    , Path
+    )
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import HSFM.GUI.Gtk.Data
+import HSFM.GUI.Gtk.Dialogs
+import HSFM.GUI.Gtk.MyView
+import HSFM.GUI.Gtk.Utils
+import HSFM.Utils.IO
+import Prelude hiding(readFile)
+import System.Glib.UTFString
+  (
+    glibToString
+  )
+import System.Posix.Env.ByteString
+  (
+    getEnv
+  )
+
+
+
+
+    -----------------
+    --[ Callbacks ]--
+    -----------------
+
+
+-- |Set callbacks, on hotkeys, events and stuff.
+setCallbacks :: MyGUI -> MyView -> IO ()
+setCallbacks mygui myview = do
+  view' <- readTVarIO $ view myview
+  case view' of
+    fmv@(FMTreeView treeView) -> do
+      _ <- treeView `on` rowActivated
+             $ (\_ _ -> withItems mygui myview open)
+      commonGuiEvents fmv
+      return ()
+    fmv@(FMIconView iconView) -> do
+      _ <- iconView `on` itemActivated
+             $ (\_ -> withItems mygui myview open)
+      commonGuiEvents fmv
+      return ()
+  menubarCallbacks
+  where
+    menubarCallbacks = do
+      -- menubar-file
+      _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
+      _ <- menubarFileOpen mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview open
+      _ <- menubarFileExecute mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview execute
+      _ <- menubarFileNew mygui `on` menuItemActivated $
+        liftIO $ newFile mygui myview
+
+      -- menubar-edit
+      _ <- menubarEditCut mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview moveInit
+      _ <- menubarEditCopy mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview copyInit
+      _ <- menubarEditRename mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview renameF
+      _ <- menubarEditPaste mygui `on` menuItemActivated $
+        liftIO $ operationFinal mygui myview
+      _ <- menubarEditDelete mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview del
+
+      -- mewnubar-view
+      _ <- menubarViewIcon mygui `on` menuItemActivated $
+        liftIO $ switchView mygui myview createIconView
+      _ <- menubarViewTree mygui `on` menuItemActivated $
+        liftIO $ switchView mygui myview createTreeView
+
+      -- menubar-help
+      _ <- menubarHelpAbout mygui `on` menuItemActivated $
+        liftIO showAboutDialog
+      return ()
+    commonGuiEvents fmv = do
+      let view = fmViewToContainer fmv
+
+      -- GUI events
+      _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
+
+      _ <- upViewB mygui `on` buttonActivated $
+           upDir mygui myview
+      _ <- homeViewB mygui `on` buttonActivated $
+           goHome mygui myview
+      _ <- refreshViewB mygui `on` buttonActivated $ do
+           cdir <- liftIO $ getCurrentDir myview
+           refreshView' mygui myview cdir
+      _ <- clearStatusBar mygui `on` buttonActivated $ do
+           popStatusbar mygui
+           writeTVarIO (operationBuffer myview) None
+
+      -- key events
+      _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+        [Control] <- eventModifier
+        "q"       <- fmap glibToString eventKeyName
+        liftIO mainQuit
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        [Control] <- eventModifier
+        "h"       <- fmap glibToString eventKeyName
+        cdir <- liftIO $ getCurrentDir myview
+        liftIO $ modifyTVarIO (settings mygui)
+                              (\x -> x { showHidden = not . showHidden $ x})
+                 >> refreshView' mygui myview cdir
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        [Alt] <- eventModifier
+        "Up"  <- fmap glibToString eventKeyName
+        liftIO $ upDir mygui myview
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        "Delete"  <- fmap glibToString eventKeyName
+        liftIO $ withItems mygui myview del
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        []            <- eventModifier
+        "Return"      <- fmap glibToString eventKeyName
+        liftIO $ withItems mygui myview open
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        [Control] <- eventModifier
+        "c"       <- fmap glibToString eventKeyName
+        liftIO $ withItems mygui myview copyInit
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        [Control] <- eventModifier
+        "x"       <- fmap glibToString eventKeyName
+        liftIO $ withItems mygui myview moveInit
+      _ <- view `on` keyPressEvent $ tryEvent $ do
+        [Control] <- eventModifier
+        "v"       <- fmap glibToString eventKeyName
+        liftIO $ operationFinal mygui myview
+
+      -- righ-click
+      _ <- view `on` buttonPressEvent $ do
+        eb <- eventButton
+        t  <- eventTime
+        case eb of
+          RightButton -> do
+              _ <- liftIO $ menuPopup (rcMenu mygui)
+                          $ Just (RightButton, t)
+              -- this is just to not screw with current selection
+              -- on right-click
+              -- TODO: this misbehaves under IconView
+              (x, y) <- eventCoordinates
+              mpath  <- liftIO $ getPathAtPos fmv (x, y)
+              case mpath of
+                -- item under the cursor, only pass on the signal
+                -- if the item under the cursor is not within the current
+                -- selection
+                (Just tp) -> do
+                  selectedTps <- liftIO $ getSelectedTreePaths mygui myview
+                  return $ elem tp selectedTps
+                -- no item under the cursor, pass on the signal
+                Nothing -> return False
+          -- not right-click, so pass on the signal
+          _ -> return False
+      _ <- rcFileOpen mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview open
+      _ <- rcFileExecute mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview execute
+      _ <- rcFileNew mygui `on` menuItemActivated $
+        liftIO $ newFile mygui myview
+      _ <- rcFileCopy mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview copyInit
+      _ <- rcFileRename mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview renameF
+      _ <- rcFilePaste mygui `on` menuItemActivated $
+        liftIO $ operationFinal mygui myview
+      _ <- rcFileDelete mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview del
+      _ <- rcFileCut mygui `on` menuItemActivated $
+        liftIO $ withItems mygui myview moveInit
+      return ()
+    getPathAtPos fmv (x, y) =
+      case fmv of
+        FMTreeView treeView -> do
+          mp <- treeViewGetPathAtPos treeView (round x, round y)
+          return $ fmap (\(p, _, _) -> p) mp
+        FMIconView iconView ->
+           fmap (\tp -> if null tp then Nothing else Just tp)
+                  $ iconViewGetPathAtPos iconView (round x) (round y)
+
+
+
+-- |Go to the url given at the 'urlBar' and visualize it in the given
+-- treeView.
+--
+-- If the url is invalid, does nothing.
+urlGoTo :: MyGUI -> MyView -> IO ()
+urlGoTo mygui myview = withErrorDialog $ do
+  fp <- entryGetText (urlBar mygui)
+  forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
+      refreshView mygui myview (Just fp')
+
+
+goHome :: MyGUI -> MyView -> IO ()
+goHome mygui myview =  withErrorDialog $ do
+  mhomedir <- getEnv "HOME"
+  refreshView mygui myview (P.parseAbs =<< mhomedir)
+
+
+-- |Supposed to be used with 'withRows'. Opens a file or directory.
+open :: [Item] -> MyGUI -> MyView -> IO ()
+open [item] mygui myview = withErrorDialog $
+  case item of
+    DirOrSym r -> do
+      nv <- readFile getFileInfo $ path r
+      refreshView' mygui myview nv
+    r ->
+      void $ openFile r
+-- this throws on the first error that occurs
+open (FileLikeList fs) _ _ = withErrorDialog $
+  forM_ fs $ \f -> void $ openFile f
+open _ _ _ = withErrorDialog
+               . throw $ InvalidOperation
+                         "Operation not supported on multiple files"
+
+
+-- |Execute a given file.
+execute :: [Item] -> MyGUI -> MyView -> IO ()
+execute [item] _ _ = withErrorDialog $
+  void $ executeFile item []
+execute _ _ _ = withErrorDialog
+                  . throw $ InvalidOperation
+                            "Operation not supported on multiple files"
+
+
+-- |Supposed to be used with 'withRows'. Deletes a file or directory.
+del :: [Item] -> MyGUI -> MyView -> IO ()
+del [item] _ _ = withErrorDialog $ do
+  let cmsg  = "Really delete \"" ++ getFPasStr item ++ "\"?"
+  withConfirmationDialog cmsg
+    $ easyDelete item
+-- this throws on the first error that occurs
+del items@(_:_) _ _ = withErrorDialog $ do
+  let cmsg  = "Really delete " ++ show (length items) ++ " files?"
+  withConfirmationDialog cmsg
+    $ forM_ items $ \item -> easyDelete item
+del _ _ _ = withErrorDialog
+              . throw $ InvalidOperation
+                        "Operation not supported on multiple files"
+
+
+-- |Initializes a file move operation.
+moveInit :: [Item] -> MyGUI -> MyView -> IO ()
+moveInit items@(_:_) mygui myview = do
+  writeTVarIO (operationBuffer myview) (FMove . MP1 . map path $ items)
+  let sbmsg = case items of
+              (item:[]) -> "Move buffer: " ++ getFPasStr item
+              _         -> "Move buffer: " ++ (show . length $ items)
+                                           ++ " items"
+  popStatusbar mygui
+  void $ pushStatusBar mygui sbmsg
+moveInit _ _ _ = withErrorDialog
+                   . throw $ InvalidOperation
+                             "No file selected!"
+
+-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
+copyInit :: [Item] -> MyGUI -> MyView -> IO ()
+copyInit items@(_:_) mygui myview = do
+  writeTVarIO (operationBuffer myview) (FCopy . CP1 . map path $ items)
+  let sbmsg = case items of
+              (item:[]) -> "Copy buffer: " ++ getFPasStr item
+              _         -> "Copy buffer: " ++ (show . length $ items)
+                                           ++ " items"
+  popStatusbar mygui
+  void $ pushStatusBar mygui sbmsg
+copyInit _ _ _ = withErrorDialog
+                   . throw $ InvalidOperation
+                             "No file selected!"
+
+
+-- |Finalizes a file operation, such as copy or move.
+operationFinal :: MyGUI -> MyView -> IO ()
+operationFinal _ myview = withErrorDialog $ do
+  op <- readTVarIO (operationBuffer myview)
+  cdir <- path <$> getCurrentDir myview
+  case op of
+    FMove (MP1 s) -> do
+      let cmsg = "Really move " ++ imsg s
+                  ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
+                  ++ "\"?"
+      withConfirmationDialog cmsg . withCopyModeDialog
+        $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
+      return ()
+    FCopy (CP1 s) -> do
+      let cmsg = "Really copy " ++ imsg s
+                 ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
+                 ++ "\"?"
+      withConfirmationDialog cmsg . withCopyModeDialog
+        $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
+      return ()
+    _ -> return ()
+  where
+    imsg s = case s of
+               (item:[]) -> "\"" ++ P.fpToString (P.fromAbs item) ++ "\""
+               items     -> (show . length $ items) ++ " items"
+
+
+-- |Go up one directory and visualize it in the treeView.
+upDir :: MyGUI -> MyView -> IO ()
+upDir mygui myview = withErrorDialog $ do
+  cdir <- getCurrentDir myview
+  nv <- goUp cdir
+  refreshView' mygui myview nv
+
+
+-- |Go up one directory and visualize it in the treeView.
+newFile :: MyGUI -> MyView -> IO ()
+newFile _ myview = withErrorDialog $ do
+  mfn   <- textInputDialog "Enter file name"
+  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
+  for_ pmfn $ \fn -> do
+    cdir  <- getCurrentDir myview
+    createFile cdir fn
+
+
+renameF :: [Item] -> MyGUI -> MyView -> IO ()
+renameF [item] _ _ = withErrorDialog $ do
+  mfn  <- textInputDialog "Enter new file name"
+  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
+  for_ pmfn $ \fn -> do
+    let cmsg = "Really rename \"" ++ getFPasStr item
+               ++ "\"" ++ " to \""
+               ++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
+                                             P.</> fn) ++ "\"?"
+    withConfirmationDialog cmsg $
+      HSFM.FileSystem.FileOperations.renameFile item fn
+renameF _ _ _ = withErrorDialog
+                  . throw $ InvalidOperation
+                            "Operation not supported on multiple files"

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

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2015 Julian Ospald
+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
@@ -16,12 +16,10 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
-module MyPrelude where
+
+module HSFM.GUI.Gtk.Callbacks where
+
+import HSFM.GUI.Gtk.Data
 
 
-import Data.List
-
-
-
-listIndices :: [a] -> [Int]
-listIndices = findIndices (const True)
+setCallbacks :: MyGUI -> MyView -> IO ()

src/HSFM/GUI/Gtk/Data.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2015 Julian Ospald
+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
@@ -18,7 +18,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
-module GUI.Gtk.Data where
+module HSFM.GUI.Gtk.Data where
 
 
 import Control.Concurrent.MVar
@@ -29,10 +29,10 @@ import Control.Concurrent.STM
   (
     TVar
   )
-import Data.DirTree
 import Graphics.UI.Gtk
-import IO.File
-import System.INotify
+import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import System.INotify.ByteString
   (
     INotify
   )
@@ -60,6 +60,8 @@ data MyGUI = MkMyGUI {
   , menubarEditRename :: ImageMenuItem
   , menubarEditPaste :: ImageMenuItem
   , menubarEditDelete :: ImageMenuItem
+  , menubarViewTree :: ImageMenuItem
+  , menubarViewIcon :: ImageMenuItem
   , menubarHelpAbout :: ImageMenuItem
   , rcMenu :: Menu
   , rcFileOpen :: ImageMenuItem
@@ -70,22 +72,14 @@ data MyGUI = MkMyGUI {
   , rcFileRename :: ImageMenuItem
   , rcFilePaste :: ImageMenuItem
   , rcFileDelete :: ImageMenuItem
-  , refreshView :: Button
+  , upViewB :: Button
+  , homeViewB :: Button
+  , refreshViewB :: Button
   , urlBar :: Entry
   , statusBar :: Statusbar
-  , treeView :: TreeView
-  -- |first column
-  , cF :: TreeViewColumn
-  -- |second column
-  , cMD :: TreeViewColumn
-  , renderTxt :: CellRendererText
-  , renderPix :: CellRendererPixbuf
+  , clearStatusBar :: Button
   , settings :: TVar FMSettings
-  , folderPix :: Pixbuf
-  , folderSymPix :: Pixbuf
-  , filePix :: Pixbuf
-  , fileSymPix :: Pixbuf
-  , errorPix :: Pixbuf
+  , scroll :: ScrolledWindow
 }
 
 
@@ -93,19 +87,28 @@ data MyGUI = MkMyGUI {
 data FMSettings = MkFMSettings {
     showHidden :: Bool
   , isLazy :: Bool
+  , iconSize :: Int
 }
 
+data FMView = FMTreeView TreeView
+            | FMIconView IconView
 
-type Row = AnchoredFile FileInfo
+type Item = File FileInfo
 
 
--- |This describes the contents of the treeView and is separated from MyGUI,
+-- |This describes the contents of the current vie and is separated from MyGUI,
 -- because we might want to have multiple views.
 data MyView = MkMyView {
-    rawModel :: TVar (ListStore Row)
-  , sortedModel :: TVar (TypedTreeModelSort Row)
-  , filteredModel :: TVar (TypedTreeModelFilter Row)
+    view            :: TVar FMView
+  , cwd             :: MVar Item
+  , rawModel        :: TVar (ListStore Item)
+  , sortedModel     :: TVar (TypedTreeModelSort Item)
+  , filteredModel   :: TVar (TypedTreeModelFilter Item)
   , operationBuffer :: TVar FileOperation
-  , inotify :: MVar INotify
+  , inotify         :: MVar INotify
 }
 
+
+fmViewToContainer :: FMView -> Container
+fmViewToContainer (FMTreeView x) =  castToContainer . toGObject $ x
+fmViewToContainer (FMIconView x) =  castToContainer . toGObject $ x

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2015 Julian Ospald
+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
@@ -18,21 +18,22 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
-module GUI.Gtk.Dialogs where
+module HSFM.GUI.Gtk.Dialogs where
 
 
-import Control.Applicative
-  (
-    (<$>)
-  )
 import Control.Exception
   (
-    try
-  , SomeException
+    catch
+  , displayException
+  , throw
+  , IOException
+  , catches
+  , Handler(..)
   )
 import Control.Monad
   (
-    when
+    forM
+  , when
   , void
   )
 import Data.Version
@@ -58,9 +59,14 @@ import Distribution.Verbosity
     silent
   )
 import Graphics.UI.Gtk
-import GUI.Gtk.Data
-import IO.File
-
+import qualified HPath as P
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileOperations
+import HSFM.GUI.Gtk.Errors
+import Paths_hsfm
+  (
+    getDataFileName
+  )
 
 
 
@@ -99,32 +105,86 @@ showConfirmationDialog str = do
 
 
 -- |Asks the user which directory copy mode he wants via dialog popup
--- and returns 'DirCopyMode'.
-showCopyModeChooserDialog :: IO DirCopyMode
-showCopyModeChooserDialog = do
+-- and returns 'DirCopyMode'. Default is always Strict, so this allows
+-- switching to Merge/Replace/Rename.
+showCopyModeDialog :: IO (Maybe CopyMode)
+showCopyModeDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    "Choose the copy mode"
-  dialogAddButton chooserDialog "Strict"  (ResponseUser 0)
-  dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
-  dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+                                    "Target exists, how to proceed?"
+  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+  _ <- dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
+  _ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 3)
   rID <- dialogRun chooserDialog
   widgetDestroy chooserDialog
   case rID of
-    ResponseUser 0 -> return Strict
-    ResponseUser 1 -> return Merge
-    ResponseUser 2 -> return Replace
+    ResponseUser 0 -> return Nothing
+    ResponseUser 1 -> return (Just Merge)
+    ResponseUser 2 -> return (Just Replace)
+    ResponseUser 3 -> do
+      mfn   <- textInputDialog "Enter new name"
+      forM mfn $ \fn -> do
+        pfn <- P.parseFn (P.userStringToFP fn)
+        return $ Rename pfn
+    _              -> throw  UnknownDialogButton
+
+
+-- |Stipped version of `showCopyModeDialog` that only allows cancelling
+-- or Renaming.
+showRenameDialog :: IO (Maybe CopyMode)
+showRenameDialog = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    "Target exists, how to proceed?"
+  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 1)
+  rID <- dialogRun chooserDialog
+  widgetDestroy chooserDialog
+  case rID of
+    ResponseUser 0 -> return Nothing
+    ResponseUser 1 -> do
+      mfn   <- textInputDialog "Enter new name"
+      forM mfn $ \fn -> do
+        pfn <- P.parseFn (P.userStringToFP fn)
+        return $ Rename pfn
+    _              -> throw  UnknownDialogButton
+
+
+-- |Attempts to run the given function with the `Strict` copy mode.
+-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
+-- the user for action via `showCopyModeDialog` and then carries out
+-- the given function again.
+withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
+withCopyModeDialog fa =
+  catch (fa Strict) $ \e ->
+    case e of
+      FileDoesExist _ -> doIt showCopyModeDialog
+      DirDoesExist  _ -> doIt showCopyModeDialog
+      SameFile _ _    -> doIt showRenameDialog
+      e'              -> throw e'
+  where
+    doIt getCm = do
+      mcm <- getCm
+      case mcm of
+        (Just Strict) -> return () -- don't try again
+        (Just cm)     -> fa cm
+        Nothing       -> return ()
 
 
 -- |Shows the about dialog from the help menu.
 showAboutDialog :: IO ()
 showAboutDialog = do
   ad       <- aboutDialogNew
-  lstr     <- readFile "LICENSE"
-  hsfmicon <- pixbufNewFromFile "data/Gtk/icons/hsfm.png"
-  pdesc    <- packageDescription <$> readPackageDescription silent "hsfm.cabal"
+  lstr     <- readFile =<< getDataFileName "LICENSE"
+  hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
+  pdesc    <- fmap packageDescription
+                   (readPackageDescription silent
+                     =<< getDataFileName "hsfm.cabal")
   set ad
     [ aboutDialogProgramName  := (unPackageName . pkgName . package) pdesc
     , aboutDialogName         := (unPackageName . pkgName . package) pdesc
@@ -152,11 +212,13 @@ withConfirmationDialog str io = do
 -- |Execute the given IO action. If the action throws exceptions,
 -- visualize them via 'showErrorDialog'.
 withErrorDialog :: IO a -> IO ()
-withErrorDialog io = do
-  r <- try io
-  either (\e -> showErrorDialog $ show (e :: SomeException))
-         (\_ -> return ())
-         r
+withErrorDialog io =
+  catches (void io)
+    [ Handler (\e -> showErrorDialog
+                       $ displayException (e :: IOException))
+    , Handler (\e -> showErrorDialog
+                       $ displayException (e :: FmIOException))
+    ]
 
 
 -- |Asks the user which directory copy mode he wants via dialog popup
@@ -170,8 +232,8 @@ textInputDialog title = do
                                     title
   entry <- entryNew
   cbox <- dialogGetActionArea chooserDialog
-  dialogAddButton chooserDialog "Ok"     (ResponseUser 0)
-  dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
+  _ <- dialogAddButton chooserDialog "Ok"     (ResponseUser 0)
+  _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
   boxPackStart (castToBox cbox) entry PackNatural 5
   widgetShowAll chooserDialog
   rID <- dialogRun chooserDialog
@@ -179,5 +241,6 @@ textInputDialog title = do
            -- TODO: make this more safe
            ResponseUser 0 -> Just <$> entryGetText entry
            ResponseUser 1 -> return Nothing
+           _              -> throw  UnknownDialogButton
   widgetDestroy chooserDialog
   return ret

src/HSFM/GUI/Gtk/Errors.hs

@@ -0,0 +1,34 @@
+{--
+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 #-}
+
+-- |Provides error handling for Gtk.
+module HSFM.GUI.Gtk.Errors where
+
+
+import Control.Exception
+import Data.Typeable
+
+
+
+data GtkException = UnknownDialogButton
+  deriving (Show, Typeable)
+
+instance Exception GtkException
+

src/HSFM/GUI/Gtk/Icons.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2015 Julian Ospald
+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
@@ -19,11 +19,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 -- |Module for Gtk icon handling.
-module GUI.Gtk.Icons where
+module HSFM.GUI.Gtk.Icons where
 
 
+import Data.Maybe
+  (
+    fromJust
+  )
 import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Gdk.Pixbuf
+import Paths_hsfm
+  (
+    getDataFileName
+  )
 
 
 -- |Icon type we use in our GUI.
@@ -41,10 +48,12 @@ getIcon :: GtkIcon    -- ^ icon we want
         -> IO Pixbuf
 getIcon icon itheme isize = do
   let iname = iconToStr icon
-  mpix <- iconThemeLoadIcon itheme iname isize IconLookupUseBuiltin
-  case mpix of
-    Just pix -> return pix
-    Nothing  -> pixbufNewFromFile ("data/Gtk/icons/" ++ iname)
+  hasicon <- iconThemeHasIcon itheme iname
+  case hasicon of
+    True -> fromJust <$> iconThemeLoadIcon itheme iname isize
+                                           IconLookupUseBuiltin
+    False -> pixbufNewFromFile =<< getDataFileName
+                                    ("data/Gtk/icons/" ++ iname ++ ".png")
   where
     iconToStr IFolder = "gtk-directory"
     iconToStr IFile   = "gtk-file"

src/HSFM/GUI/Gtk/MyGUI.hs

@@ -0,0 +1,120 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module HSFM.GUI.Gtk.MyGUI where
+
+
+import Control.Concurrent.STM
+  (
+    newTVarIO
+  )
+import Graphics.UI.Gtk
+import HSFM.GUI.Gtk.Data
+import Paths_hsfm
+  (
+    getDataFileName
+  )
+
+
+
+
+    -------------------------
+    --[ Main Window Setup ]--
+    -------------------------
+
+
+-- |Set up the GUI. This only creates the permanent widgets.
+createMyGUI :: IO MyGUI
+createMyGUI = do
+
+  let settings' = MkFMSettings False True 24
+  settings <- newTVarIO settings'
+
+  builder <- builderNew
+  builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
+
+  -- get the pre-defined gui widgets
+  rootWin           <- builderGetObject builder castToWindow
+                       "rootWin"
+  scroll            <- builderGetObject builder castToScrolledWindow
+                       "mainScroll"
+  menubarFileQuit   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileQuit"
+  menubarFileOpen   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileOpen"
+  menubarFileExecute <- builderGetObject builder castToImageMenuItem
+                        "menubarFileExecute"
+  menubarFileNew    <- builderGetObject builder castToImageMenuItem
+                       "menubarFileNew"
+  menubarEditCut    <- builderGetObject builder castToImageMenuItem
+                       "menubarEditCut"
+  menubarEditCopy   <- builderGetObject builder castToImageMenuItem
+                       "menubarEditCopy"
+  menubarEditRename <- builderGetObject builder castToImageMenuItem
+                       "menubarEditRename"
+  menubarEditPaste  <- builderGetObject builder castToImageMenuItem
+                       "menubarEditPaste"
+  menubarEditDelete <- builderGetObject builder castToImageMenuItem
+                      "menubarEditDelete"
+  menubarHelpAbout  <- builderGetObject builder castToImageMenuItem
+                      "menubarHelpAbout"
+  urlBar            <- builderGetObject builder castToEntry
+                       "urlBar"
+  statusBar         <- builderGetObject builder castToStatusbar
+                       "statusBar"
+  clearStatusBar    <- builderGetObject builder castToButton
+                       "clearStatusBar"
+  rcMenu            <- builderGetObject builder castToMenu
+                       "rcMenu"
+  rcFileOpen        <- builderGetObject builder castToImageMenuItem
+                       "rcFileOpen"
+  rcFileExecute     <- builderGetObject builder castToImageMenuItem
+                       "rcFileExecute"
+  rcFileNew         <- builderGetObject builder castToImageMenuItem
+                       "rcFileNew"
+  rcFileCut         <- builderGetObject builder castToImageMenuItem
+                       "rcFileCut"
+  rcFileCopy        <- builderGetObject builder castToImageMenuItem
+                       "rcFileCopy"
+  rcFileRename      <- builderGetObject builder castToImageMenuItem
+                       "rcFileRename"
+  rcFilePaste       <- builderGetObject builder castToImageMenuItem
+                       "rcFilePaste"
+  rcFileDelete      <- builderGetObject builder castToImageMenuItem
+                       "rcFileDelete"
+  upViewB           <- builderGetObject builder castToButton
+                       "upViewB"
+  homeViewB         <- builderGetObject builder castToButton
+                       "homeViewB"
+  refreshViewB      <- builderGetObject builder castToButton
+                       "refreshViewB"
+  menubarViewTree   <- builderGetObject builder castToImageMenuItem
+                       "menubarViewTree"
+  menubarViewIcon   <- builderGetObject builder castToImageMenuItem
+                       "menubarViewIcon"
+
+  -- construct the gui object
+  let mygui  = MkMyGUI {..}
+
+  -- sets the default icon
+  _ <- windowSetDefaultIconFromFile
+         =<< getDataFileName "data/Gtk/icons/hsfm.png"
+
+  return mygui

src/HSFM/GUI/Gtk/MyView.hs

@@ -0,0 +1,360 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+
+module HSFM.GUI.Gtk.MyView where
+
+
+import Control.Concurrent.MVar
+  (
+    newEmptyMVar
+  , putMVar
+  , tryTakeMVar
+  )
+import Control.Concurrent.STM
+  (
+    newTVarIO
+  , readTVarIO
+  )
+import Control.Exception
+  (
+    try
+  , SomeException
+  )
+import Data.Foldable
+  (
+    for_
+  )
+import Data.Maybe
+  (
+    catMaybes
+  , fromJust
+  )
+import Graphics.UI.Gtk
+import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
+import HPath
+  (
+    Path
+  , Abs
+  )
+import qualified HPath as P
+import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import HSFM.GUI.Glib.GlibString()
+import HSFM.GUI.Gtk.Data
+import HSFM.GUI.Gtk.Icons
+import HSFM.GUI.Gtk.Utils
+import HSFM.Utils.IO
+import Prelude hiding(readFile)
+import System.INotify.ByteString
+  (
+    addWatch
+  , initINotify
+  , killINotify
+  , EventVariety(..)
+  )
+import System.IO.Error
+  (
+    tryIOError
+  )
+
+
+
+
+-- |Constructs the initial MyView object with a few dummy models.
+-- It also initializes the callbacks.
+createMyView :: MyGUI
+             -> IO FMView
+             -> IO MyView
+createMyView mygui iofmv = do
+  operationBuffer <- newTVarIO None
+
+  inotify <- newEmptyMVar
+
+  -- create dummy models, so we don't have to use MVar
+  rawModel <- newTVarIO =<< listStoreNew []
+  filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
+                             =<< readTVarIO rawModel
+  sortedModel <- newTVarIO =<< treeModelSortNewWithModel
+                           =<< readTVarIO filteredModel
+  cwd <- newEmptyMVar
+  view' <- iofmv
+  view  <- newTVarIO view'
+
+  let myview = MkMyView {..}
+
+  -- set the bindings
+  setCallbacks mygui myview
+
+  -- add the treeview to the scroll container
+  let oview = fmViewToContainer view'
+  containerAdd (scroll mygui) oview
+
+  return myview
+
+
+-- |Switch the existing view in `MyView` with the one that the
+-- io action returns.
+switchView :: MyGUI -> MyView -> IO FMView -> IO ()
+switchView mygui myview iofmv = do
+  view' <- readTVarIO $ view myview
+  let oview = fmViewToContainer view'
+
+  widgetDestroy oview
+
+  nview' <- iofmv
+  let nview = fmViewToContainer nview'
+
+  writeTVarIO (view myview) nview'
+
+  setCallbacks mygui myview
+
+  containerAdd (scroll mygui) nview
+  widgetShow nview
+
+  refreshView mygui myview Nothing
+
+
+-- |Createss an IconView.
+createIconView :: IO FMView
+createIconView = do
+  iconv <- iconViewNew
+  iconViewSetSelectionMode iconv SelectionMultiple
+  iconViewSetColumns iconv (-1)
+  iconViewSetSpacing iconv 2
+  iconViewSetMargin iconv 0
+  {- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
+  {- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
+
+  return $ FMIconView iconv
+
+
+-- |Creates a TreeView.
+createTreeView :: IO FMView
+createTreeView = do
+  -- create the final view
+  treeView <- treeViewNew
+  -- set selection mode
+  tvs <- treeViewGetSelection treeView
+  treeSelectionSetMode tvs SelectionMultiple
+
+  -- create final tree model columns
+  renderTxt <- cellRendererTextNew
+  renderPix <- cellRendererPixbufNew
+  let ct = cellText   :: (CellRendererTextClass cr) => Attr cr String
+      cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
+
+  -- filename column
+  cF <- treeViewColumnNew
+  treeViewColumnSetTitle        cF ("Filename" :: String)
+  treeViewColumnSetResizable    cF True
+  treeViewColumnSetClickable    cF True
+  treeViewColumnSetSortColumnId cF 1
+  cellLayoutPackStart cF renderPix False
+  cellLayoutPackStart cF renderTxt True
+  _ <- treeViewAppendColumn treeView cF
+  cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
+  cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
+
+  -- date column
+  cMD <- treeViewColumnNew
+  treeViewColumnSetTitle        cMD ("Date" :: String)
+  treeViewColumnSetResizable    cMD True
+  treeViewColumnSetClickable    cMD True
+  treeViewColumnSetSortColumnId cMD 2
+  cellLayoutPackStart cMD renderTxt True
+  _ <- treeViewAppendColumn treeView cMD
+  cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
+
+  -- permissions column
+  cP <- treeViewColumnNew
+  treeViewColumnSetTitle        cP ("Permission" :: String)
+  treeViewColumnSetResizable    cP True
+  treeViewColumnSetClickable    cP True
+  treeViewColumnSetSortColumnId cP 3
+  cellLayoutPackStart cP renderTxt True
+  _ <- treeViewAppendColumn treeView cP
+  cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
+
+  return $ FMTreeView treeView
+
+
+-- |Re-reads the current directory or the given one and updates the View.
+-- This is more or less a wrapper around `refreshView'`
+--
+-- If the third argument is Nothing, it tries to re-read the current directory.
+-- If that fails, it reads "/" instead.
+--
+-- If the third argument is (Just path) it tries to read "path". If that
+-- fails, it reads "/" instead.
+refreshView :: MyGUI
+            -> MyView
+            -> Maybe (Path Abs)
+            -> IO ()
+refreshView mygui myview mfp =
+  case mfp of
+    Just fp  -> do
+      -- readFileWithFileInfo can just outright fail...
+      ecdir <- tryIOError (readFile getFileInfo fp)
+      case ecdir of
+        Right cdir ->
+          -- ...or return an `AnchordFile` with a Failed constructor,
+          -- both of which need to be handled here
+          if (failed cdir)
+            then refreshView mygui myview =<< getAlternativeDir
+            else refreshView' mygui myview cdir
+        Left _ -> refreshView mygui myview =<< getAlternativeDir
+    Nothing  -> refreshView mygui myview =<< getAlternativeDir
+    where
+      getAlternativeDir = do
+        ecd <- try (getCurrentDir myview) :: IO (Either SomeException
+                                                     Item)
+        case ecd of
+          Right dir -> return (Just $ path dir)
+          Left _    -> return (P.parseAbs "/")
+
+
+-- |Refreshes the View based on the given directory.
+--
+-- If the directory is not a Dir or a Symlink pointing to a Dir, then
+-- calls `refreshView` with the 3rd argument being Nothing.
+refreshView' :: MyGUI
+             -> MyView
+             -> Item
+             -> IO ()
+refreshView' mygui myview dt@(DirOrSym _) = do
+  newRawModel  <- fileListStore dt myview
+  writeTVarIO (rawModel myview) newRawModel
+
+  view' <- readTVarIO $ view myview
+
+  _ <- tryTakeMVar (cwd myview)
+  putMVar (cwd myview) dt
+
+  -- get selected items
+  tps <- getSelectedTreePaths mygui myview
+  trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
+
+  constructView mygui myview
+
+  -- reselect selected items
+  -- TODO: not implemented for icon view yet
+  case view' of
+    FMTreeView treeView -> do
+      tvs <- treeViewGetSelection treeView
+      ntps <- mapM treeRowReferenceGetPath trs
+      mapM_ (treeSelectionSelectPath tvs) ntps
+    _ -> return ()
+refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
+refreshView' _ _ _ = return ()
+
+
+-- |Constructs the visible View with the current underlying mutable models,
+-- which are retrieved from 'MyGUI'.
+--
+-- This sort of merges the components mygui and myview and fires up
+-- the actual models.
+constructView :: MyGUI
+              -> MyView
+              -> IO ()
+constructView mygui myview = do
+  settings' <- readTVarIO $ settings mygui
+
+  -- pix stuff
+  iT           <- iconThemeGetDefault
+  folderPix    <- getIcon IFolder iT (iconSize settings')
+  folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
+  filePix      <- getIcon IFile iT (iconSize settings')
+  fileSymPix   <- getSymlinkIcon IFile iT (iconSize settings')
+  errorPix     <- getIcon IError iT (iconSize settings')
+  let dirtreePix Dir{}           = folderPix
+      dirtreePix FileLike{}      = filePix
+      dirtreePix DirSym{}        = folderSymPix
+      dirtreePix FileLikeSym{}   = fileSymPix
+      dirtreePix Failed{}        = errorPix
+      dirtreePix BrokenSymlink{} = errorPix
+      dirtreePix _               = errorPix
+
+
+  view' <- readTVarIO $ view myview
+
+  cdirp <- path <$> getCurrentDir myview
+
+  -- update urlBar
+  entrySetText (urlBar mygui) (P.fromAbs cdirp)
+
+  rawModel' <- readTVarIO $ rawModel myview
+
+  -- filtering
+  filteredModel' <- treeModelFilterNew rawModel' []
+  writeTVarIO (filteredModel myview) filteredModel'
+  treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
+     hidden <- showHidden <$> readTVarIO (settings mygui)
+     item   <- treeModelGetRow rawModel' iter >>= (P.basename . path)
+     if hidden
+       then return True
+       else return $ not . P.hiddenFile $ item
+
+  -- sorting
+  sortedModel' <- treeModelSortNewWithModel filteredModel'
+  writeTVarIO (sortedModel myview) sortedModel'
+  treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
+      cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
+      cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
+      item1  <- treeModelGetRow rawModel' cIter1
+      item2  <- treeModelGetRow rawModel' cIter2
+      return $ compare item1 item2
+  treeSortableSetSortColumnId sortedModel' 1 SortAscending
+
+  -- set values
+  treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
+                     dirtreePix
+  treeModelSetColumn rawModel' (makeColumnIdString 1)
+                     (P.toFilePath . fromJust . P.basename . path)
+  treeModelSetColumn rawModel' (makeColumnIdString 2)
+                     packModTime
+  treeModelSetColumn rawModel' (makeColumnIdString 3)
+                     packPermissions
+
+  -- update model of view
+  case view' of
+    FMTreeView treeView -> do
+      treeViewSetModel treeView sortedModel'
+      treeViewSetRubberBanding treeView True
+    FMIconView iconView -> do
+      iconViewSetModel iconView (Just sortedModel')
+      iconViewSetPixbufColumn iconView
+                              (makeColumnIdPixbuf 0 :: ColumnId item Pixbuf)
+      iconViewSetTextColumn iconView
+                            (makeColumnIdString 1 :: ColumnId item String)
+
+  -- add watcher
+  mi <- tryTakeMVar (inotify myview)
+  for_ mi $ \i -> killINotify i
+  newi <- initINotify
+  _ <- addWatch
+         newi
+         [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
+         (P.fromAbs cdirp)
+         (\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
+  putMVar (inotify myview) newi
+
+  return ()

src/HSFM/GUI/Gtk/Utils.hs

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

src/HSFM/Utils/IO.hs

@@ -1,6 +1,6 @@
 {--
 HSFM, a filemanager written in Haskell.
-Copyright (C) 2015 Julian Ospald
+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
@@ -18,8 +18,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
+
 -- |Random and general IO utilities.
-module IO.Utils where
+module HSFM.Utils.IO where
 
 
 import Control.Concurrent.STM
@@ -39,17 +40,23 @@ import Control.Monad
   )
 
 
+-- |Atomically write a TVar.
 writeTVarIO :: TVar a -> a -> IO ()
 writeTVarIO tvar val = atomically $ writeTVar tvar val
 
 
+-- |Atomically modify a TVar.
 modifyTVarIO :: TVar a -> (a -> a) -> IO ()
 modifyTVarIO tvar f = atomically $ modifyTVar tvar f
 
 
+-- |If the value of the first argument is True, then execute the action
+-- provided in the second argument, otherwise do nothing.
 whenM :: Monad m => m Bool -> m () -> m ()
 whenM mb a = mb >>= (`when` a)
 
 
+-- |If the value of the first argument is False, then execute the action
+-- provided in the second argument, otherwise do nothing.
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM mb a = mb >>= (`unless` a)

src/HSFM/Utils/MyPrelude.hs

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

src/IO/Error.hs

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

src/IO/File.hs

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