Restructure module layout

src/HSFM/FileSystem/Errors.hs

@@ -0,0 +1,172 @@
+{--
+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 HSFM.FileSystem.Errors where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Exception
+import Control.Monad
+  (
+    unless
+  , void
+  , when
+  )
+import Data.List
+  (
+    isPrefixOf
+  )
+import Data.Typeable
+import Foreign.C.Error
+  (
+    getErrno
+  , Errno
+  )
+import HSFM.Utils.IO
+import System.FilePath
+  (
+    equalFilePath
+  , isAbsolute
+  , takeFileName
+  )
+import System.IO.Error
+  (
+    catchIOError
+  )
+
+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
+                   | InvalidOperation String
+                   | InvalidFileName
+  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)
+
+
+-- |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 == en
+      then a2
+      else ioError e
+
+
+handleIOError :: (IOError -> IO a) -> IO a -> IO a
+handleIOError a1 a2 = catchIOError a2 a1
+
+
+-- |Checks if the given file exists and is not a directory. This follows
+-- symlinks, but will return True if the symlink is broken.
+doesFileExist :: FilePath -> IO Bool
+doesFileExist fp =
+  handleIOError (\_ -> return False) $ do
+    fs <- catchIOError (PF.getFileStatus fp) $ \_ ->
+      PF.getSymbolicLinkStatus 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 :: FilePath -> IO Bool
+doesDirectoryExist fp =
+  handleIOError (\_ -> return False) $ do
+    fs <- PF.getFileStatus fp
+    return $ PF.isDirectory fs

src/HSFM/FileSystem/FileOperations.hs

@@ -0,0 +1,496 @@
+{--
+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 HSFM.FileSystem.FileOperations where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Exception
+  (
+    throw
+  )
+import Control.Monad
+  (
+    unless
+  )
+import Data.Foldable
+  (
+    for_
+  )
+import Foreign.C.Error
+  (
+    eXDEV
+  )
+import HPath
+    (
+      Path
+    , Fn
+    )
+import qualified HPath as P
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileType
+import HSFM.Utils.IO
+import HSFM.Utils.MyPrelude
+import System.FilePath
+  (
+    (</>)
+  )
+import System.Posix.Directory
+  (
+    createDirectory
+  , removeDirectory
+  )
+import System.Posix.Files
+  (
+    createSymbolicLink
+  , fileMode
+  , readSymbolicLink
+  , getSymbolicLinkStatus
+  , groupExecuteMode
+  , groupReadMode
+  , groupWriteMode
+  , otherExecuteMode
+  , otherReadMode
+  , otherWriteMode
+  , ownerModes
+  , ownerReadMode
+  , ownerWriteMode
+  , rename
+  , unionFileModes
+  , removeLink
+  )
+import System.Posix.IO
+  (
+    closeFd
+  , createFile
+  )
+import System.Posix.Types
+  (
+    FileMode
+  )
+import System.Process
+  (
+    spawnProcess
+  , ProcessHandle
+  )
+
+import qualified Data.ByteString  as BS
+
+
+
+-- 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  (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)
+                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 (AnchoredFile FileInfo)
+          | MC  (AnchoredFile FileInfo)
+                (AnchoredFile FileInfo)
+                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
+
+
+-- |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 cm)) = moveFile cm 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
+
+
+
+    --------------------
+    --[ File Copying ]--
+    --------------------
+
+
+-- TODO: allow renaming
+-- |Copies a directory to the given destination with the specified
+-- `DirCopyMode`. Excludes symlinks.
+copyDir :: CopyMode
+        -> AnchoredFile FileInfo  -- ^ source dir
+        -> AnchoredFile FileInfo  -- ^ destination dir
+        -> IO ()
+copyDir _ AFileInvFN _ = throw InvalidFileName
+copyDir _ _ AFileInvFN = throw InvalidFileName
+copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
+             to@(_ :/ Dir {})
+  = do
+    let fromp    = fullPath from
+        fromp'   = P.toFilePath fromp
+        top      = fullPath to
+        destdirp = top P.</> fromn
+        destdirp' = P.toFilePath destdirp
+    throwDestinationInSource fromp' destdirp'
+    throwSameFile fromp' destdirp'
+
+    createDestdir destdirp fmode
+    destdir <- HSFM.FileSystem.FileType.readFileWithFileInfo destdirp
+
+    contents <- readDirectoryContents' (fullPath from)
+
+    for_ contents $ \f ->
+      case f of
+        (_ :/ SymLink {})  -> recreateSymlink cm f destdir
+        (_ :/ Dir {})      -> copyDir cm f destdir
+        (_ :/ RegFile {})  -> copyFileToDir Replace f destdir
+        _                  -> 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 =<<
+                   HSFM.FileSystem.FileType.readFileWithFileInfo destdir)
+          createDirectory destdir' fmode
+copyDir _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Recreate a symlink.
+recreateSymlink :: CopyMode
+                -> AnchoredFile FileInfo  -- ^ the old symlink file
+                -> AnchoredFile FileInfo  -- ^ destination dir of the
+                                          --   new symlink file
+                -> IO ()
+recreateSymlink _ AFileInvFN _ = throw InvalidFileName
+recreateSymlink _ _ AFileInvFN = throw InvalidFileName
+recreateSymlink cm    symf@(_ :/ SymLink {})
+                   symdest@(_ :/ Dir {})
+  = do
+    sympoint <- readSymbolicLink (P.fromAbs . fullPath $ symf)
+    let symname = fullPath symdest P.</> (name . file $ symf)
+    case cm of
+      Merge   -> delOld symname
+      Replace -> delOld symname
+      _       -> return ()
+    createSymbolicLink sympoint (P.fromAbs symname)
+  where
+    delOld symname = do
+      f <- HSFM.FileSystem.FileType.readFileWithFileInfo symname
+      unless (failed . file $ f)
+             (easyDelete f)
+recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |TODO: handle EAGAIN exception for non-blocking IO
+-- |Low-level function to copy a given file to the given path. The fileMode
+-- is preserved. The file is always overwritten if accessible.
+copyFile' :: FilePath -> FilePath -> IO ()
+copyFile' from to = do
+  fromFstatus <- getSymbolicLinkStatus from
+  fromContent <- BS.readFile from
+  fd          <- System.Posix.IO.createFile to
+                   (System.Posix.Files.fileMode fromFstatus)
+  closeFd fd
+  BS.writeFile to fromContent
+
+
+-- |Copies the given file to the given file destination, overwriting it.
+-- Excludes symlinks.
+overwriteFile :: AnchoredFile FileInfo  -- ^ source file
+              -> AnchoredFile FileInfo  -- ^ destination file
+              -> IO ()
+overwriteFile AFileInvFN _ = throw InvalidFileName
+overwriteFile _ AFileInvFN = throw InvalidFileName
+overwriteFile from@(_ :/ RegFile {})
+                to@(_ :/ RegFile {})
+  = do
+    let from' = P.fromAbs . fullPath $ from
+        to'   = P.fromAbs . fullPath $ to
+    throwSameFile from' to'
+    copyFile' from' to'
+overwriteFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Copies the given file to the given dir with the same filename.
+-- Excludes symlinks.
+copyFileToDir :: CopyMode
+              -> AnchoredFile FileInfo
+              -> AnchoredFile FileInfo
+              -> IO ()
+copyFileToDir _ AFileInvFN _ = throw InvalidFileName
+copyFileToDir _ _ AFileInvFN = throw InvalidFileName
+copyFileToDir cm from@(_ :/ RegFile fn _)
+                   to@(_ :/ Dir {})
+  = do
+    let from' = P.fromAbs . fullPath $ from
+        to'   = P.fromAbs (fullPath to P.</> fn)
+    case cm of
+      Strict -> throwFileDoesExist to'
+      _      -> return ()
+    copyFile' from' to'
+copyFileToDir _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Copies a file, directory or symlink. In case of a symlink, it is just
+-- recreated, even if it points to a directory.
+easyCopy :: CopyMode
+         -> AnchoredFile FileInfo
+         -> AnchoredFile FileInfo
+         -> IO ()
+easyCopy cm from@(_ :/ SymLink {})
+              to@(_ :/ Dir {})
+  = recreateSymlink cm from to
+easyCopy cm from@(_ :/ RegFile fn _)
+              to@(_ :/ Dir {})
+  = copyFileToDir cm from to
+easyCopy cm from@(_ :/ Dir fn _)
+              to@(_ :/ Dir {})
+  = copyDir cm from to
+easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+
+    ---------------------
+    --[ File Deletion ]--
+    ---------------------
+
+
+-- |Deletes a symlink, which can either point to a file or directory.
+deleteSymlink :: AnchoredFile FileInfo -> IO ()
+deleteSymlink AFileInvFN = throw InvalidFileName
+deleteSymlink f@(_ :/ SymLink {})
+  = removeLink (P.toFilePath . fullPath $ f)
+deleteSymlink _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Deletes the given file, never symlinks.
+deleteFile :: AnchoredFile FileInfo -> IO ()
+deleteFile AFileInvFN = throw InvalidFileName
+deleteFile f@(_ :/ RegFile {})
+  = removeLink (P.toFilePath . fullPath $ f)
+deleteFile _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Deletes the given directory, never symlinks.
+deleteDir :: AnchoredFile FileInfo -> IO ()
+deleteDir AFileInvFN = throw InvalidFileName
+deleteDir f@(_ :/ Dir {})
+  = removeDirectory (P.toFilePath . fullPath $ f)
+deleteDir _ = throw $ InvalidOperation "wrong input type"
+
+
+-- TODO: check if we have permissions at all to remove the directory,
+--       before we go recursively messing with it
+-- |Deletes the given directory recursively.
+deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
+deleteDirRecursive AFileInvFN = throw InvalidFileName
+deleteDirRecursive f@(_ :/ Dir {}) = do
+  let fp = fullPath f
+  files <- readDirectoryContents' fp
+  for_ files $ \file ->
+    case file of
+      (_ :/ SymLink {}) -> deleteSymlink file
+      (_ :/ Dir {})     -> deleteDirRecursive file
+      (_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file)
+      _                 -> throw $ FileDoesExist (P.toFilePath . fullPath $ file)
+  removeDirectory . P.toFilePath $ fp
+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 :: AnchoredFile FileInfo -> 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.
+openFile :: AnchoredFile a
+         -> IO ProcessHandle
+openFile AFileInvFN = throw InvalidFileName
+openFile f = spawnProcess "xdg-open" [P.fromAbs . fullPath $ f]
+
+
+-- |Executes a program with the given arguments.
+executeFile :: AnchoredFile FileInfo  -- ^ program
+            -> [String]               -- ^ arguments
+            -> IO ProcessHandle
+executeFile AFileInvFN _ = throw InvalidFileName
+executeFile prog@(_ :/ RegFile {}) args
+  = spawnProcess (P.fromAbs . fullPath $ prog) args
+executeFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+    ---------------------
+    --[ File Creation ]--
+    ---------------------
+
+
+createFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
+createFile AFileInvFN _ = throw InvalidFileName
+createFile _ InvFN      = throw InvalidFileName
+createFile (ADirOrSym td) (ValFN fn) = do
+  let fullp = P.fromAbs (fullPath td P.</> fn)
+  throwFileDoesExist fullp
+  fd <- System.Posix.IO.createFile fullp newFilePerms
+  closeFd fd
+createFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
+createDir AFileInvFN _ = throw InvalidFileName
+createDir _ InvFN      = throw InvalidFileName
+createDir (ADirOrSym td) (ValFN fn) = do
+  let fullp = P.fromAbs (fullPath td P.</> fn)
+  throwDirDoesExist fullp
+  createDirectory fullp newFilePerms
+createDir _ _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+    ----------------------------
+    --[ File Renaming/Moving ]--
+    ----------------------------
+
+
+renameFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
+renameFile AFileInvFN _ = throw InvalidFileName
+renameFile _ InvFN      = throw InvalidFileName
+renameFile af (ValFN fn) = do
+  let fromf = P.fromAbs . fullPath $ af
+      tof   = P.fromAbs (anchor af P.</> fn)
+  throwFileDoesExist tof
+  throwSameFile fromf tof
+  rename fromf tof
+renameFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Move a given file to the given target directory.
+moveFile :: CopyMode
+         -> AnchoredFile FileInfo -- ^ file to move
+         -> AnchoredFile FileInfo -- ^ base target directory
+         -> IO ()
+moveFile _ AFileInvFN _ = throw InvalidFileName
+moveFile _ _ AFileInvFN = throw InvalidFileName
+moveFile cm from to@(_ :/ Dir {}) = do
+  let from'  = fullPath from
+      froms' = P.fromAbs . fullPath $ from
+      to'    = fullPath to P.</> (name . file $ from)
+      tos'   = P.fromAbs (fullPath to P.</> (name . file $ from))
+  case cm of
+    Strict  -> throwFileDoesExist tos'
+    Merge   -> delOld to'
+    Replace -> delOld to'
+  throwSameFile froms' tos'
+  catchErrno eXDEV (rename froms' tos') $ do
+    easyCopy Strict from to
+    easyDelete from
+  where
+    delOld to = do
+      to' <- HSFM.FileSystem.FileType.readFileWithFileInfo to
+      unless (failed . file $ to') (easyDelete to')
+moveFile _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+
+    -----------------------
+    --[ 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

src/HSFM/FileSystem/FileType.hs

@@ -0,0 +1,809 @@
+{--
+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 HSFM.FileSystem.FileType where
+
+
+import Control.Applicative
+  (
+    (<*>)
+  , (<$>)
+  , (<|>)
+  , pure
+  )
+import Control.Arrow
+  (
+    first
+  )
+import Control.Exception
+  (
+    handle
+  )
+import Control.Exception.Base
+  (
+    onException
+  , IOException
+  )
+import Control.Monad.State.Lazy
+  (
+
+  )
+import Data.Default
+import Data.List
+  (
+    delete
+  , foldl'
+  , isPrefixOf
+  , sort
+  , sortBy
+  , (\\)
+  )
+import Data.Maybe
+  (
+    catMaybes
+  , fromMaybe
+  )
+import Data.Ord
+  (
+    comparing
+  )
+import Data.Time.Clock.POSIX
+  (
+    POSIXTime
+  , posixSecondsToUTCTime
+  )
+import Data.Time
+  (
+    UTCTime(..)
+  )
+import Data.Traversable
+  (
+    for
+  )
+import Data.Word
+  (
+    Word64
+  )
+import HPath
+    (
+      Abs
+    , Path
+    , Fn
+    , Rel
+    , pattern Path
+    )
+import qualified HPath as P
+import HSFM.Utils.MyPrelude
+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 System.Posix.Files as PF
+import qualified System.Posix.Directory as PFD
+
+
+
+    ----------------------------
+    --[ BASE TYPES ]--
+    ----------------------------
+
+
+-- |Represents a file. The `anchor` field is the path
+-- to that file without the filename.
+data AnchoredFile a =
+  (:/) { anchor :: Path Abs, 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 :: Path Fn
+  , err  :: IOException
+  }
+  | Dir {
+    name :: Path Fn
+  , fvar :: a
+  }
+  | RegFile {
+    name :: Path Fn
+  , fvar :: a
+  }
+  -- TODO: add raw symlink dest (not normalized) to SymLink?
+  | SymLink {
+    name    :: Path Fn
+  , fvar    :: a
+  , sdest   :: AnchoredFile a  -- ^ symlink madness,
+                               --   we need to know where it points to
+  , rawdest :: FilePath
+  }
+  | BlockDev {
+    name :: Path Fn
+  , fvar :: a
+  }
+  | CharDev {
+    name :: Path Fn
+  , fvar :: a
+  }
+  | NamedPipe {
+    name :: Path Fn
+  , fvar :: a
+  }
+  | Socket {
+    name :: Path Fn
+  , 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)
+
+
+
+
+    ------------------------------------
+    --[ ViewPatterns/PatternSynonyms ]--
+    ------------------------------------
+
+
+-- |Converts a viewpattern like function written for `File` to one
+-- for `AnchoredFile`.
+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)
+
+
+
+---- Filetypes ----
+
+
+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
+
+
+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
+  -- 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 AFileLike f <- (afileLike -> (True, f))
+-- |Like `AFileLike`, except on File.
+pattern FileLike  f <- (fileLike  -> (True, f))
+
+-- |Matches a list of directories or symlinks pointing to directories.
+pattern DirList fs <- (\fs -> (and . fmap (fst . sadir) $ 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 . safileLike)
+                                     $ fs, fs) -> (True, fs))
+
+
+---- Filenames ----
+
+invalidFileName :: Path Fn -> (Bool, Path Fn)
+invalidFileName p@(Path "")   = (True, p)
+invalidFileName p@(Path ".")  = (True, p)
+invalidFileName p@(Path "..") = (True, p)
+invalidFileName p@(Path fn)   = (elem pathSeparator fn, p)
+
+
+-- |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))
+
+-- |Like `InvFN`, but for AnchoredFile.
+pattern AFileInvFN  <- (fst . invalidFileName . name . file -> True)
+-- |Like `InvFN`, but for File.
+pattern FileInvFN   <- (fst . invalidFileName . name        -> True)
+
+
+---- Symlinks ----
+
+abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
+abrokenSymlink f = convertViewP brokenSymlink f
+
+
+brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
+brokenSymlink f = (isBrokenSymlink f, 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)
+
+
+-- |Matches on symlinks pointing to file-like files only.
+pattern AFileLikeSym f <- (afileLikeSym -> (True, f))
+-- |Like `AFileLikeSym`, except on File.
+pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))
+
+-- |Matches on broken symbolic links.
+pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
+-- |Like `ABrokenSymlink`, except on File.
+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 ADirOrSym f <- (sadir -> (True, f))
+-- |Like `ADirOrSym`, except on File.
+pattern DirOrSym  f <- (sdir  -> (True, f))
+
+-- |Matches on symlinks pointing to directories only.
+pattern ADirSym  f <- (adirSym -> (True, f))
+-- |Like `ADirSym`, except on File.
+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))
+-- |Like `AFileLikeOrSym`, except on File.
+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'
+
+
+-- |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 ]--
+    ----------------------------
+
+
+-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
+-- variables via the given function.
+readWith :: (Path Abs -> IO a)  -- ^ function that fills the free
+                                --   a variable
+         -> Path Abs            -- ^ Path to read
+         -> IO (AnchoredFile a)
+readWith ff p = do
+  let fn = P.basename p
+      bd = P.dirname p
+      p' = P.toFilePath p
+  bd' <- P.canonicalizePath bd -- TODO: this will cause a dialog to pop up on error
+  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' fn'
+      | PF.isSymbolicLink    fs = do
+          -- symlink madness, we need to make sure we save the correct
+          -- AnchoredFile
+          let fp = bd' P.</> fn'
+          x <- PF.readSymbolicLink (P.fromAbs fp)
+          resolvedSyml <- handleDT bd' fn' $ do
+            -- watch out, we call </> from 'filepath' here, but it is safe
+            -- TODO: could it happen that too many '..' lead
+            -- to something like '/' after normalization?
+            let sfp = if isAbsolute x then x else (P.fromAbs bd') </> x
+            sf <- PF.getFileStatus sfp -- important to break infinite symbolic
+                                       -- link cycle
+            rsfp <- P.realPath sfp
+            readWith ff =<< P.parseAbs rsfp
+          return $ SymLink fn' fv resolvedSyml x
+      | PF.isDirectory       fs = return $ Dir       fn' fv
+      | PF.isRegularFile     fs = return $ RegFile   fn' fv
+      | PF.isBlockDevice     fs = return $ BlockDev  fn' fv
+      | PF.isCharacterDevice fs = return $ CharDev   fn' fv
+      | PF.isNamedPipe       fs = return $ NamedPipe fn' fv
+      | PF.isSocket          fs = return $ Socket    fn' fv
+      | otherwise               = return $ Failed    fn' (userError
+                                                          "Unknown filetype!")
+
+
+-- |Reads a file Path into an AnchoredFile.
+readFile :: (Path Abs -> IO a) -> Path Abs -> IO (AnchoredFile a)
+readFile ff fp = readWith ff fp
+
+readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
+readFileWithFileInfo = HSFM.FileSystem.FileType.readFile getFileInfo
+
+-- |Build a list of AnchoredFile, given the path to a directory, filling
+-- the free variables via `getFileInfo`. This includes the "." and ".."
+-- directories.
+readDirectoryContents :: Path Abs -> IO [AnchoredFile FileInfo]
+readDirectoryContents fp = readDirectoryContentsWith getAllDirsFiles getFileInfo fp
+
+
+-- |Build a list of AnchoredFile, given the path to a directory, filling
+-- the free variables via `getFileInfo`. This excludes the "." and ".."
+-- directories.
+readDirectoryContents' :: Path Abs -> IO [AnchoredFile FileInfo]
+readDirectoryContents' fp = readDirectoryContentsWith getDirsFiles getFileInfo fp
+
+
+-- |Same as readDirectoryContents but allows us to, for example, use
+-- ByteString.readFile to return a tree of ByteStrings.
+readDirectoryContentsWith :: (Path Abs -> IO [Path Fn])
+                          -> (Path Abs -> IO a)
+                          -> Path Abs
+                          -> IO [AnchoredFile a]
+readDirectoryContentsWith getfiles ff p = do
+  files <- getfiles p
+  fcs <- mapM (\x -> HSFM.FileSystem.FileType.readFile ff $ p P.</> x) files
+  return $ removeNonexistent fcs
+
+
+
+
+
+    -----------------
+    --[ 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
+
+
+
+
+---- IO HELPERS: ----
+
+
+-- |Go up one directory in the filesystem hierarchy.
+goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
+goUp af@(Path "" :/ _) = return af
+goUp    (bp :/ _)      = HSFM.FileSystem.FileType.readFile getFileInfo bp
+
+
+-- |Go up one directory in the filesystem hierarchy.
+goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
+goUp' fp = HSFM.FileSystem.FileType.readFile getFileInfo $ P.dirname fp
+
+
+-- |Get the contents of a directory.
+getContents :: AnchoredFile FileInfo
+            -> IO [AnchoredFile FileInfo]
+getContents (ADirOrSym af) = readDirectoryContents (fullPath af)
+getContents _              = return []
+
+
+getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath])
+              -> Path Abs
+              -> IO [Path Fn]
+getDirsFiles' filterf fp = do
+  dirstream <- PFD.openDirStream . P.toFilePath $ fp
+  let mdirs :: [FilePath] -> IO [FilePath]
+      mdirs dirs = do
+        -- make sure we close the directory stream in case of errors
+        dir <- onException (PFD.readDirStream dirstream)
+                           (PFD.closeDirStream dirstream)
+        if dir == ""
+          then return dirs
+          else mdirs (dir `filterf` dirs)
+  dirs <- mdirs []
+  PFD.closeDirStream dirstream
+  return $ catMaybes (fmap P.parseFn dirs)
+
+
+-- |Get all files of a given directory and return them as a List.
+-- This includes "." and "..".
+getAllDirsFiles :: Path Abs -> IO [Path Fn]
+getAllDirsFiles = getDirsFiles' (:)
+
+
+-- |Get all files of a given directory and return them as a List.
+-- This excludes "." and "..".
+getDirsFiles :: Path Abs -> IO [Path Fn]
+getDirsFiles = getDirsFiles' insert
+  where
+    insert dir dirs = case dir of
+      "."  -> dirs
+      ".." -> dirs
+      _    -> dir : dirs
+
+
+-- |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.
+-- TODO: only handle IO exceptions
+handleDT :: Path Abs
+         -> Path Fn
+         -> 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: ----
+
+
+-- |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 af@(SymLink _ _ (_ :/ Failed {}) _) = True
+isBrokenSymlink _ = False
+
+
+---- OTHER: ----
+
+
+-- |Check whether the given file is a hidden file.
+hiddenFile :: Path Fn -> Bool
+hiddenFile (Path ".")  = False
+hiddenFile (Path "..") = False
+hiddenFile (Path fn)   = "." `isPrefixOf` fn
+
+
+-- |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
+
+
+-- |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
+
+
+-- |Get the full path of the file.
+fullPath :: AnchoredFile a -> Path Abs
+fullPath (bp :/ f) = bp P.</> name f
+
+
+-- |Get the full path of the file, converted to a `FilePath`.
+fullPathS :: AnchoredFile a -> FilePath
+fullPathS = P.fromAbs . fullPath
+
+
+-- |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 = 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/Gtk.hs

@@ -0,0 +1,54 @@
+{--
+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 Graphics.UI.Gtk
+import HSFM.GUI.Gtk.Data
+import HSFM.GUI.Gtk.MyGUI
+import HSFM.GUI.Gtk.MyView
+import Safe
+  (
+    headDef
+  )
+import System.Environment
+  (
+    getArgs
+  )
+
+
+main :: IO ()
+main = do
+  _ <- initGUI
+
+  args <- getArgs
+
+  mygui <- createMyGUI
+
+  myview <- createMyView mygui createTreeView
+
+  refreshView mygui myview (Just $ headDef "/" args)
+
+  widgetShowAll (rootWin mygui)
+
+  _ <- mainGUI
+  return ()
+

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -0,0 +1,332 @@
+{--
+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 HSFM.GUI.Gtk.Callbacks where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  , (<*>)
+  )
+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 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 System.FilePath
+  (
+    isAbsolute
+  , (</>)
+  )
+import System.Glib.UTFString
+  (
+    glibToString
+  )
+
+
+
+
+
+    -----------------
+    --[ Callbacks ]--
+    -----------------
+
+
+-- |Set callbacks, on hotkeys, events and stuff.
+setCallbacks :: MyGUI -> MyView -> IO ()
+setCallbacks mygui myview = do
+  view' <- readTVarIO $ view myview
+  case view' of
+    FMTreeView treeView -> do
+      _ <- treeView `on` rowActivated
+             $ (\_ _ -> withItems mygui myview open)
+      commonGuiEvents treeView
+      return ()
+    FMIconView iconView -> do
+      _ <- iconView `on` itemActivated
+             $ (\_ -> withItems mygui myview open)
+      commonGuiEvents iconView
+      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 view = do
+      -- GUI events
+      _ <- urlBar mygui `on` entryActivated $ urlGoTo 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 -> liftIO $ menuPopup (rcMenu mygui)
+            $ Just (RightButton, t)
+          _           -> return ()
+        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 ()
+
+
+-- |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?
+  refreshView mygui myview (Just fp)
+
+
+-- |Supposed to be used with 'withRows'. Opens a file or directory.
+open :: [Item] -> MyGUI -> MyView -> IO ()
+open [item] mygui myview = withErrorDialog $
+  case item of
+    ADirOrSym r -> do
+      nv <- HSFM.FileSystem.FileType.readFileWithFileInfo $ fullPath r
+      refreshView' mygui myview nv
+    r ->
+      void $ openFile r
+-- this throws on the first error that occurs
+open (FileLikeList fs) mygui myview = 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] mygui myview = 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] mygui myview = withErrorDialog $ do
+  let cmsg  = "Really delete \"" ++ P.fromAbs (fullPath item) ++ "\"?"
+  withConfirmationDialog cmsg
+    $ easyDelete item
+-- this throws on the first error that occurs
+del items@(_:_) mygui myview = 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 [item] mygui myview = do
+  writeTVarIO (operationBuffer myview) (FMove . MP1 $ item)
+  let sbmsg = "Move buffer: " ++ P.fromAbs (fullPath item)
+  popStatusbar mygui
+  void $ pushStatusBar mygui sbmsg
+moveInit _ _ _ = withErrorDialog
+                   . throw $ InvalidOperation
+                             "Operation not supported on multiple files"
+
+-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
+copyInit :: [Item] -> MyGUI -> MyView -> IO ()
+copyInit [item] mygui myview = do
+  writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item)
+  let sbmsg = "Copy buffer: " ++ P.fromAbs (fullPath item)
+  popStatusbar mygui
+  void $ pushStatusBar mygui sbmsg
+copyInit _ _ _ = withErrorDialog
+                   . throw $ InvalidOperation
+                             "Operation not supported on multiple files"
+
+
+-- |Finalizes a file operation, such as copy or move.
+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 \"" ++ P.fromAbs (fullPath s)
+                  ++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
+      withConfirmationDialog cmsg . withCopyModeDialog
+        $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
+      return ()
+    FCopy (CP1 s) -> do
+      let cmsg = "Really copy \"" ++ P.fromAbs (fullPath s)
+                 ++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
+      withConfirmationDialog cmsg . withCopyModeDialog
+        $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
+      return ()
+    _ -> return ()
+
+
+-- |Go up one directory and visualize it in the treeView.
+upDir :: MyGUI -> MyView -> IO ()
+upDir mygui myview = withErrorDialog $ do
+  cdir <- getCurrentDir myview
+  rawModel'    <- readTVarIO $ rawModel myview
+  sortedModel' <- readTVarIO $ sortedModel myview
+  nv <- goUp cdir
+  refreshView' 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"
+  let pmfn = P.parseFn =<< mfn
+  for_ pmfn $ \fn -> do
+    cdir  <- getCurrentDir myview
+    createFile cdir fn
+
+
+renameF :: [Item] -> MyGUI -> MyView -> IO ()
+renameF [item] mygui myview = withErrorDialog $ do
+  mfn  <- textInputDialog "Enter new file name"
+  let pmfn = P.parseFn =<< mfn
+  for_ pmfn $ \fn -> do
+    let cmsg = "Really rename \"" ++ P.fromAbs (fullPath item)
+               ++ "\"" ++ " to \"" ++ P.fromAbs (anchor 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

@@ -0,0 +1,25 @@
+{--
+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.
+--}
+
+
+module HSFM.GUI.Gtk.Callbacks where
+
+import HSFM.GUI.Gtk.Data
+
+
+setCallbacks :: MyGUI -> MyView -> IO ()

src/HSFM/GUI/Gtk/Data.hs

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

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -0,0 +1,209 @@
+{--
+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 HSFM.GUI.Gtk.Dialogs where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Exception
+  (
+    catch
+  , throw
+  , try
+  , SomeException
+  )
+import Control.Monad
+  (
+    when
+  , void
+  )
+import Data.Version
+  (
+    showVersion
+  )
+import Distribution.Package
+  (
+    PackageIdentifier(..)
+  , PackageName(..)
+  )
+import Distribution.PackageDescription
+  (
+    GenericPackageDescription(..)
+  , PackageDescription(..)
+  )
+import Distribution.PackageDescription.Parse
+  (
+    readPackageDescription
+  )
+import Distribution.Verbosity
+  (
+    silent
+  )
+import Graphics.UI.Gtk
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileOperations
+import HSFM.GUI.Gtk.Data
+import Paths_hsfm
+  (
+    getDataFileName
+  )
+
+
+
+
+    ---------------------
+    --[ Dialog popups ]--
+    ---------------------
+
+
+-- |Pops up an error Dialog with the given String.
+showErrorDialog :: String -> IO ()
+showErrorDialog str = do
+  errorDialog <- messageDialogNew Nothing
+                                  [DialogDestroyWithParent]
+                                  MessageError
+                                  ButtonsClose
+                                  str
+  _ <- dialogRun errorDialog
+  widgetDestroy errorDialog
+
+
+-- |Asks the user for confirmation and returns True/False.
+showConfirmationDialog :: String -> IO Bool
+showConfirmationDialog str = do
+  confirmDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsYesNo
+                                    str
+  rID <- dialogRun confirmDialog
+  widgetDestroy confirmDialog
+  case rID of
+    ResponseYes -> return True
+    ResponseNo  -> return False
+    _           -> return False
+
+
+-- |Asks the user which directory copy mode he wants via dialog popup
+-- and returns 'DirCopyMode'.
+showCopyModeDialog :: IO CopyMode
+showCopyModeDialog = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    "Target exists, how to proceed?"
+  dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+  dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
+  dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+  rID <- dialogRun chooserDialog
+  widgetDestroy chooserDialog
+  case rID of
+    ResponseUser 0 -> return Strict
+    ResponseUser 1 -> return Merge
+    ResponseUser 2 -> return Replace
+
+
+-- |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
+      DirDoesExist  _ -> doIt
+      e               -> throw e
+  where
+    doIt = do cm <- showCopyModeDialog
+              case cm of
+                Strict -> return () -- don't try again
+                _      -> fa cm
+
+
+-- |Shows the about dialog from the help menu.
+showAboutDialog :: IO ()
+showAboutDialog = do
+  ad       <- aboutDialogNew
+  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
+    , aboutDialogVersion      := (showVersion . pkgVersion . package) pdesc
+    , aboutDialogCopyright    := copyright pdesc
+    , aboutDialogComments     := description pdesc
+    , aboutDialogLicense      := Just lstr
+    , aboutDialogWebsite      := homepage pdesc
+    , aboutDialogAuthors      := [author pdesc]
+    , aboutDialogLogo         := Just hsfmicon
+    , aboutDialogWrapLicense  := True
+    ]
+  _ <- dialogRun ad
+  widgetDestroy ad
+
+
+-- |Carry out an IO action with a confirmation dialog.
+-- If the user presses "No", then do nothing.
+withConfirmationDialog :: String -> IO () -> IO ()
+withConfirmationDialog str io = do
+  run <- showConfirmationDialog str
+  when run io
+
+
+-- |Execute the given IO action. If the action throws exceptions,
+-- visualize them via 'showErrorDialog'.
+withErrorDialog :: IO a -> IO ()
+withErrorDialog io = do
+  r <- try io
+  either (\e -> showErrorDialog $ show (e :: SomeException))
+         (\_ -> return ())
+         r
+
+
+-- |Asks the user which directory copy mode he wants via dialog popup
+-- and returns 'DirCopyMode'.
+textInputDialog :: String -> IO (Maybe String)
+textInputDialog title = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    title
+  entry <- entryNew
+  cbox <- dialogGetActionArea chooserDialog
+  dialogAddButton chooserDialog "Ok"     (ResponseUser 0)
+  dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
+  boxPackStart (castToBox cbox) entry PackNatural 5
+  widgetShowAll chooserDialog
+  rID <- dialogRun chooserDialog
+  ret <- case rID of
+           -- TODO: make this more safe
+           ResponseUser 0 -> Just <$> entryGetText entry
+           ResponseUser 1 -> return Nothing
+  widgetDestroy chooserDialog
+  return ret

src/HSFM/GUI/Gtk/Icons.hs

@@ -0,0 +1,72 @@
+{--
+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 for Gtk icon handling.
+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.
+data GtkIcon = IFolder
+             | SymL
+             | IFile
+             | IError
+
+
+-- |Gets an icon from the default icon theme and falls back to project-icons
+-- if not found. The requested icon size is not guaranteed.
+getIcon :: GtkIcon    -- ^ icon we want
+        -> IconTheme  -- ^ which icon theme to get the icon from
+        -> Int        -- ^ requested icon size
+        -> IO Pixbuf
+getIcon icon itheme isize = do
+  let iname = iconToStr icon
+  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"
+    iconToStr IError  = "error"
+    iconToStr SymL    = "emblem-symbolic-link"
+
+
+getSymlinkIcon :: GtkIcon -> IconTheme -> Int -> IO Pixbuf
+getSymlinkIcon icon itheme isize = do
+  pix    <- pixbufCopy =<< getIcon icon itheme isize
+  sympix <- getIcon SymL itheme isize
+
+  pixbufScale sympix pix 0 0 12 12 0 0 0.5 0.5 InterpNearest
+
+  return pix

src/HSFM/GUI/Gtk/MyGUI.hs

@@ -0,0 +1,115 @@
+{--
+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 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"
+  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,322 @@
+{--
+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 HSFM.GUI.Gtk.MyView where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Concurrent.MVar
+  (
+    newEmptyMVar
+  , putMVar
+  , tryTakeMVar
+  )
+import Control.Concurrent.STM
+  (
+    newTVarIO
+  , readTVarIO
+  )
+import Data.Foldable
+  (
+    for_
+  )
+import Data.Maybe
+  (
+    catMaybes
+  , fromJust
+  , fromMaybe
+  )
+import Graphics.UI.Gtk
+import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
+import qualified HPath as P
+import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import HSFM.GUI.Gtk.Data
+import HSFM.GUI.Gtk.Icons
+import HSFM.GUI.Gtk.Utils
+import HSFM.Utils.IO
+import System.FilePath
+  (
+    isAbsolute
+  )
+import System.INotify
+  (
+    addWatch
+  , initINotify
+  , killINotify
+  , EventVariety(..)
+  , Event(..)
+  )
+
+
+
+
+-- |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
+
+  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"
+  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
+
+  return $ FMTreeView treeView
+
+
+-- |Re-reads the current directory or the given one and updates the View.
+refreshView :: MyGUI
+            -> MyView
+            -> Maybe FilePath
+            -> IO ()
+refreshView mygui myview mfp =
+  case mfp of
+    Just fp  -> do
+      let mdir = fromMaybe (fromJust $ P.parseAbs "/") (P.parseAbs fp)
+      cdir <- HSFM.FileSystem.FileType.readFileWithFileInfo mdir
+      refreshView' mygui myview cdir
+    Nothing  -> refreshView' mygui myview =<< getCurrentDir myview
+
+
+-- |Refreshes the View based on the given directory.
+refreshView' :: MyGUI
+             -> MyView
+             -> AnchoredFile FileInfo
+             -> IO ()
+refreshView' mygui myview dt@(ADirOrSym _) = do
+  newRawModel  <- fileListStore dt myview
+  writeTVarIO (rawModel myview) newRawModel
+
+  view' <- readTVarIO $ view myview
+
+  -- 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' _ _ _ = 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 <- anchor <$> getFirstItem 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    <- (name . file) <$> treeModelGetRow rawModel' iter
+     if hidden
+       then return True
+       else return $ not . 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 . file)
+  treeModelSetColumn rawModel' (makeColumnIdString 1)
+                     (P.fromRel . name . file)
+  treeModelSetColumn rawModel' (makeColumnIdString 2)
+                     (packModTime . file)
+  treeModelSetColumn rawModel' (makeColumnIdString 3)
+                     (packPermissions . file)
+
+  -- 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
+  w <- addWatch
+         newi
+         [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
+         (P.fromAbs cdirp)
+         (\_ -> postGUIAsync $ refreshView mygui myview (Just $ P.fromAbs cdirp))
+  putMVar (inotify myview) newi
+
+  return ()

src/HSFM/GUI/Gtk/Utils.hs

@@ -0,0 +1,148 @@
+{--
+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 HSFM.GUI.Gtk.Utils where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+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
+
+
+
+    -----------------
+    --[ 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' mygui 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 :: AnchoredFile FileInfo  -- ^ current dir
+              -> MyView
+              -> IO (ListStore Item)
+fileListStore dt myview = do
+  cs <- HSFM.FileSystem.FileType.getContents dt
+  listStoreNew cs
+
+
+-- |Currently unsafe. This is used to obtain any item (possibly the '.' item)
+-- and extract the "current working directory" from it.
+getFirstItem :: MyView
+            -> IO (AnchoredFile FileInfo)
+getFirstItem myview = do
+  rawModel' <- readTVarIO $ rawModel myview
+  iter      <- fromJust <$> treeModelGetIterFirst rawModel'
+  treeModelGetRow rawModel' iter
+
+
+-- |Currently unsafe. Gets the current directory via `getFirstItem` and
+-- `goUp`.
+getCurrentDir :: MyView
+              -> IO (AnchoredFile FileInfo)
+getCurrentDir myview = getFirstItem myview >>= goUp
+
+
+
+
+-- |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

@@ -0,0 +1,55 @@
+{--
+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 #-}
+
+-- |Random and general IO utilities.
+module HSFM.Utils.IO where
+
+
+import Control.Concurrent.STM
+  (
+    atomically
+  )
+import Control.Concurrent.STM.TVar
+  (
+    writeTVar
+  , modifyTVar
+  , TVar
+  )
+import Control.Monad
+  (
+    when
+  , unless
+  )
+
+
+writeTVarIO :: TVar a -> a -> IO ()
+writeTVarIO tvar val = atomically $ writeTVar tvar val
+
+
+modifyTVarIO :: TVar a -> (a -> a) -> IO ()
+modifyTVarIO tvar f = atomically $ modifyTVar tvar f
+
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb a = mb >>= (`when` a)
+
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM mb a = mb >>= (`unless` a)

src/HSFM/Utils/MyPrelude.hs

@@ -0,0 +1,33 @@
+{--
+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.
+--}
+
+module HSFM.Utils.MyPrelude where
+
+
+import Data.Default
+import Data.List
+
+
+
+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