Initial commit

src/Data/DirTree.hs

@@ -0,0 +1,714 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+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.Ord
+  (
+    comparing
+  )
+import Data.List
+  (
+    delete
+  , sort
+  , sortBy
+  , (\\)
+  )
+import Data.Time
+  (
+    UTCTime
+  , formatTime
+  )
+import Data.Word
+  (
+    Word64
+  )
+import System.Directory
+  (
+    Permissions(..)
+  , createDirectoryIfMissing
+  , doesFileExist
+  , getDirectoryContents
+  , getModificationTime
+  , getPermissions
+  , writable
+  , searchable
+  )
+import System.EasyFile
+  (
+    getCreationTime
+  , getChangeTime
+  , getAccessTime
+  , getFileSize
+  , hasSubDirectories
+  , isSymlink
+  )
+import System.FilePath
+  (
+    combine
+  , equalFilePath
+  , joinPath
+  , splitDirectories
+  , (</>)
+  )
+import System.IO
+  (
+    IOMode
+  , Handle
+  , openFile
+  )
+import System.IO.Error
+  (
+    ioeGetErrorType
+  , isDoesNotExistErrorType
+  )
+import System.IO.Unsafe
+  (
+    unsafeInterleaveIO
+  )
+import System.Locale
+  (
+    defaultTimeLocale
+  , rfc822DateFormat
+  )
+import qualified Data.Bitraversable as BT
+import qualified Data.Bifunctor     as BF
+import qualified Data.Bifoldable    as BFL
+import qualified Data.Traversable   as T
+
+
+
+    ----------------------------
+    --[ BASE TYPES ]--
+    ----------------------------
+
+
+-- |Weak type to distinguish between FilePath and FileName.
+type FileName = String
+
+
+-- |A simple wrapper to hold a base directory name, which can be either an
+-- absolute or relative path. This lets us give the DirTree a context, while
+-- still letting us store only directory and file /names/ (not full paths) in
+-- the DirTree. (uses an infix constructor; don't be scared)
+data AnchoredDirTree a b =
+  (:/) { anchor :: FilePath, dirTree :: DirTree a b }
+  deriving (Eq, Ord, 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 DirTree a b =
+    Failed {
+    name :: FileName
+  , err  :: IOException
+  }
+  | Dir {
+    name     :: FileName
+  , contents :: [DirTree a b]
+  , dir      :: a
+  }
+  | File {
+    name :: FileName
+  , file :: b
+  } deriving Show
+
+
+-- |All possible directory information we could ever need from a directory.
+data DirTreeInfo =
+  DirInfo {
+    permissions  :: Permissions
+  , creationTime :: Maybe UTCTime
+  , changeTime   :: Maybe UTCTime
+  , modTime      :: UTCTime
+  , accessTime   :: UTCTime
+  , sym          :: Bool
+  , hasSubDirs   :: Maybe Bool
+  }
+  | FileInfo {
+    permissions  :: Permissions
+  , creationTime :: Maybe UTCTime
+  , changeTime   :: Maybe UTCTime
+  , modTime      :: UTCTime
+  , accessTime   :: UTCTime
+  , sym          :: Bool
+  , fileSize     :: Word64
+  }
+  deriving (Show, Eq, Ord)
+
+
+
+
+    ----------------------------
+    --[ INSTANCES ]--
+    ----------------------------
+
+
+instance BF.Bifunctor DirTree where
+  bimap = BT.bimapDefault
+
+
+instance BFL.Bifoldable DirTree where
+  bifoldMap = BT.bifoldMapDefault
+
+
+instance BT.Bitraversable DirTree where
+    bitraverse f1 f2 (Dir n cs b) =
+      Dir n
+        <$> T.traverse (BT.bitraverse f1 f2) cs
+        <*> f1 b
+    bitraverse _ f2 (File n a) =
+      File n <$> f2 a
+    bitraverse _ _ (Failed n e) =
+      pure (Failed n e)
+
+
+-- | Two DirTrees are equal if they have the same constructor, the same name
+-- (and in the case of `Dir`s) their sorted `contents` are equal:
+instance (Eq a, Eq b) => Eq (DirTree a b) where
+    (File n a) == (File n' a') = n == n' && a == a'
+    (Dir n cs _) == (Dir n' cs' _) =
+        n == n' && sortBy comparingConstr cs == sortBy comparingConstr cs'
+     -- after comparing above we can hand off to shape equality function:
+    d == d' = equalShape d d'
+
+
+-- | First compare constructors: Failed < Dir < File...
+-- Then compare `name`...
+-- Then compare free variable parameter of `File` constructors
+instance (Ord a, Ord b, Eq a, Eq b) => Ord (DirTree a b) where
+    compare (File n a) (File n' a') =
+        case compare n n' of
+             EQ -> compare a a'
+             el -> el
+    compare (Dir n cs b) (Dir n' cs' b') =
+        case compare n n' of
+             EQ -> case compare b b' of
+               EQ -> comparing sort cs cs'
+               el -> el
+             el -> el
+     -- after comparing above we can hand off to shape ord function:
+    compare d d' = comparingShape d d'
+
+
+-- for convenience:
+instance BF.Bifunctor AnchoredDirTree where
+    bimap fd ff (b:/d) = b :/ BF.bimap fd ff d
+
+
+
+-- given the same fixity as <$>, is that right?
+infixl 4 </$>
+
+
+
+    ----------------------------
+    --[ HIGH LEVEL FUNCTIONS ]--
+    ----------------------------
+
+
+-- | build an AnchoredDirTree, given the path to a directory, opening the files
+-- using readFile.
+-- Uses `readDirectoryWith` internally and has the effect of traversing the
+-- entire directory structure. See `readDirectoryWithL` for lazy production
+-- of a DirTree structure.
+readDirectory :: FilePath -> IO (AnchoredDirTree String String)
+readDirectory = readDirectoryWith readFile return
+
+
+-- | same as readDirectory but allows us to, for example, use
+-- ByteString.readFile to return a tree of ByteStrings.
+readDirectoryWith :: (FilePath -> IO a)
+                  -> (FilePath -> IO b)
+                  -> FilePath
+                  -> IO (AnchoredDirTree a b)
+readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p
+
+
+-- | A "lazy" version of `readDirectoryWith` that does IO operations as needed
+-- i.e. as the tree is traversed in pure code.
+-- /NOTE:/ This function uses unsafeInterleaveIO under the hood. I believe
+-- our use here is safe, but this function is experimental in this release:
+readDirectoryWithL :: (FilePath -> IO a)
+                   -> (FilePath -> IO b)
+                   -> FilePath
+                   -> IO (AnchoredDirTree a b)
+readDirectoryWithL fd ff p = buildWith' buildLazilyUnsafe' fd ff p
+
+
+-- | write a DirTree of strings to disk. Clobbers files of the same name.
+-- Doesn't affect files in the directories (if any already exist) with
+-- different names. Returns a new AnchoredDirTree where failures were
+-- lifted into a `Failed` constructor:
+writeDirectory :: AnchoredDirTree String String -> IO (AnchoredDirTree () ())
+writeDirectory = writeDirectoryWith writeFile
+
+
+-- | writes the directory structure to disk and uses the provided function to
+-- write the contents of `Files` to disk. The return value of the function will
+-- become the new `contents` of the returned, where IO errors at each node are
+-- replaced with `Failed` constructors. The returned tree can be compared to
+-- the passed tree to see what operations, if any, failed:
+writeDirectoryWith :: (FilePath -> af -> IO bf)
+                   -> AnchoredDirTree ad af
+                   -> IO (AnchoredDirTree () bf)
+writeDirectoryWith f (b:/t) = (b:/) <$> write' b t
+    where write' b' (File n a) = handleDT n $
+              File n <$> f (b'</>n) a
+          write' b' (Dir n cs _) = handleDT n $
+              do let bas = b'</>n
+                 createDirectoryIfMissing True bas
+                 Dir n <$> mapM (write' bas) cs <*> return ()
+          write' _ (Failed n e) = return $ Failed n e
+
+
+
+
+
+
+    -----------------------------
+    --[ LOWER LEVEL FUNCTIONS ]--
+    -----------------------------
+
+
+-- | a simple application of readDirectoryWith openFile:
+openDirectory :: FilePath -> IOMode -> IO (AnchoredDirTree () Handle)
+openDirectory p m = readDirectoryWith (\_ -> return ()) (flip openFile m) p
+
+
+
+-- | builds a DirTree from the contents of the directory passed to it, saving
+-- the base directory in the Anchored* wrapper. Errors are caught in the tree in
+-- the Failed constructor. The 'file' fields initially are populated with full
+-- paths to the files they are abstracting.
+build :: FilePath -> IO (AnchoredDirTree FilePath FilePath)
+build = buildWith' buildAtOnce' return return   -- we say 'return' here to get
+                                                -- back a  tree  of  FilePaths
+
+
+-- | identical to `build` but does directory reading IO lazily as needed:
+buildL :: FilePath -> IO (AnchoredDirTree FilePath FilePath)
+buildL = buildWith' buildLazilyUnsafe' return return
+
+
+
+
+    -- -- -- helpers: -- -- --
+
+
+type UserIO a = FilePath -> IO a
+type Builder a b = UserIO a -> UserIO b -> FilePath -> IO (DirTree a b)
+
+-- remove non-existent file errors, which are artifacts of the "non-atomic"
+-- nature of traversing a system firectory tree:
+buildWith' :: Builder a b
+           -> UserIO a
+           -> UserIO b
+           -> FilePath
+           -> IO (AnchoredDirTree a b)
+buildWith' bf' fd ff p =
+    do tree <- bf' fd ff p
+       return (baseDir p :/ removeNonexistent tree)
+
+
+
+-- IO function passed to our builder and finally executed here:
+buildAtOnce' :: Builder a b
+buildAtOnce' fd ff p = handleDT n $
+           do isFile <- doesFileExist p
+              if isFile
+                 then  File n <$> ff p
+                 else do cs <- getDirsFiles p
+                         Dir n
+                           <$> T.mapM (buildAtOnce' fd ff . combine p) cs
+                           <*> fd p
+     where n = topDir p
+
+
+-- using unsafeInterleaveIO to get "lazy" traversal:
+buildLazilyUnsafe' :: Builder a b
+buildLazilyUnsafe' fd ff p = handleDT n $
+           do isFile <- doesFileExist p
+              if isFile
+                 then File n <$> ff p
+                 -- HERE IS THE UNSAFE CODE:
+                 else do
+                   -- this is not behind unsafeInterleaveIO on purpose
+                   -- otherwise we might get runtime exceptions
+                   files <- getDirsFiles p
+                   contents <- unsafeInterleaveIO $
+                      mapM (rec . combine p) files
+                   d <- fd p
+                   return $ Dir n contents d
+     where rec = buildLazilyUnsafe' fd ff
+           n = topDir p
+
+
+
+
+    -----------------
+    --[ UTILITIES ]--
+    -----------------
+
+
+
+---- HANDLING FAILURES ----
+
+
+-- | True if any Failed constructors in the tree
+anyFailed :: DirTree a b -> Bool
+anyFailed = not . successful
+
+-- | True if there are no Failed constructors in the tree
+successful :: DirTree a b -> Bool
+successful = null . failures
+
+
+-- | returns true if argument is a `Failed` constructor:
+failed :: DirTree a b -> Bool
+failed (Failed _ _) = True
+failed _            = False
+
+
+-- | returns a list of 'Failed' constructors only:
+failures :: DirTree a b -> [DirTree a b]
+failures = filter failed . flattenDir
+
+
+-- | maps a function to convert Failed DirTrees to Files or Dirs
+failedMap :: (FileName -> IOException -> DirTree a b) -> DirTree a b -> DirTree a b
+failedMap f = transformDir unFail
+    where unFail (Failed n e) = f n e
+          unFail c            = c
+
+
+---- ORDERING AND EQUALITY ----
+
+
+-- | Recursively sort a directory tree according to the Ord instance
+sortDir :: (Ord a, Ord b) => DirTree a b -> DirTree a b
+sortDir = sortDirBy compare
+
+-- | Recursively sort a tree as in `sortDir` but ignore the file contents of a
+-- File constructor
+sortDirShape :: DirTree a b -> DirTree a b
+sortDirShape = sortDirBy comparingShape  where
+
+  -- HELPER:
+sortDirBy :: (DirTree a b -> DirTree a b -> Ordering) -> DirTree a b -> DirTree a b
+sortDirBy cf = transformDir sortD
+    where sortD (Dir n cs a) = Dir n (sortBy cf cs) a
+          sortD c            = c
+
+
+-- | Tests equality of two trees, ignoring their free variable portion. Can be
+-- used to check if any files have been added or deleted, for instance.
+equalShape :: DirTree a b -> DirTree c d -> Bool
+equalShape d d' = comparingShape d d' == EQ
+
+-- TODO: we should use equalFilePath here, but how to sort properly? with System.Directory.canonicalizePath, before compare?
+
+-- | a compare function that ignores the free "file" type variable:
+comparingShape :: DirTree a b -> DirTree c d -> Ordering
+comparingShape (Dir n cs _) (Dir n' cs' _) =
+    case compare n n' of
+         EQ -> comp (sortCs cs) (sortCs cs')
+         el -> el
+    where sortCs = sortBy comparingConstr
+           -- stolen from [] Ord instance:
+          comp []     []     = EQ
+          comp []     (_:_)  = LT
+          comp (_:_)  []     = GT
+          comp (x:xs) (y:ys) = case comparingShape x y of
+                                    EQ    -> comp xs ys
+                                    other -> other
+ -- else simply compare the flat constructors, non-recursively:
+comparingShape t t'  = comparingConstr t t'
+
+
+ -- HELPER: a non-recursive comparison
+comparingConstr :: DirTree a b -> DirTree a1 b1 -> Ordering
+comparingConstr (Failed _ _) (Dir _ _ _)  = LT
+comparingConstr (Failed _ _) (File _ _)   = LT
+comparingConstr (File _ _)   (Failed _ _) = GT
+comparingConstr (File _ _)   (Dir _ _ _)  = GT
+comparingConstr (Dir _ _ _)  (Failed _ _) = GT
+comparingConstr (Dir _ _ _)  (File _ _)   = 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 ----
+
+-- | If the argument is a 'Dir' containing a sub-DirTree matching 'FileName'
+-- then return that subtree, appending the 'name' of the old root 'Dir' to the
+-- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@.
+dropTo :: FileName -> AnchoredDirTree a b -> Maybe (AnchoredDirTree a b)
+dropTo n' (p :/ Dir n ds' _) = search ds'
+    where search [] = Nothing
+          search (d:ds) | equalFilePath n' (name d) = Just ((p</>n) :/ d)
+                        | otherwise = search ds
+dropTo _ _ = Nothing
+
+
+find :: FilePath
+     -> AnchoredDirTree a b
+     -> Either String (AnchoredDirTree a b)
+find f d = findAbs f d <|> findRel f d
+
+
+-- |Finds a file or directory inside an @AnchoredDirTree@. This only
+-- looks at the subdirectories of the underlying @DirTree@. If you
+-- want to compare the name of the topmost @DirTree@ as well, use @find'@.
+findRel :: FilePath
+        -> AnchoredDirTree a b
+        -> Either String (AnchoredDirTree a b)
+findRel f d =
+  go (splitDirectories f) d
+  where
+    go (f:fs) (p :/ Dir n ds _) = search ds f >>= go fs
+      where
+        search [] _ = Left "Directory or file not found!"
+        search (d:ds) n | equalFilePath n (name d) = Right ((p</>n) :/ d)
+                        | otherwise                = search ds n
+    go [] d = Right d
+    go _ (p :/ Failed _ err) = Left $ show err
+    go _ _  = Left "Directory or file not found!"
+
+
+-- |Finds a file or directory inside an @AnchoredDirTree@. This also
+-- looks at the topmost @DirTree@ and compares the first path component
+-- with it. If you only want to look at subdirectories, use @find@.
+findAbs :: FilePath
+        -> AnchoredDirTree a b
+        -> Either String (AnchoredDirTree a b)
+findAbs f d =
+  go (splitDirectories f) d
+  where
+    go (f':fs) (_ :/ Dir n _ _)
+      | equalFilePath f' n = find (joinPath fs) d
+      | otherwise          = Left "Directory or file not found!"
+    go _ (p :/ Failed _ err) = Left $ show err
+    go _ _  = Left "Directory or file not found!"
+
+
+-- | applies the predicate to each constructor in the tree, removing it (and
+-- its children, of course) when the predicate returns False. The topmost
+-- constructor will always be preserved:
+filterDir :: (DirTree a b -> Bool) -> DirTree a b -> DirTree a b
+filterDir p = transformDir filterD
+    where filterD (Dir n cs a) = Dir n (filter p cs) a
+          filterD c            = c
+
+
+-- | Flattens a `DirTree` into a (never empty) list of tree constructors. `Dir`
+-- constructors will have [] as their `contents`:
+flattenDir :: DirTree a b -> [ DirTree a b ]
+flattenDir (Dir n cs a) = Dir n [] a : concatMap flattenDir cs
+flattenDir f            = [f]
+
+
+
+
+
+-- | Allows for a function on a bare DirTree to be applied to an AnchoredDirTree
+-- within a Functor. Very similar to and useful in combination with `<$>`:
+(</$>) :: (Functor f) => (DirTree a a1 -> DirTree b b1) -> f (AnchoredDirTree a a1) ->
+                         f (AnchoredDirTree b b1)
+(</$>) f = fmap (\(b :/ t) -> b :/ f t)
+
+
+    ---------------
+    --[ HELPERS ]--
+    ---------------
+
+
+---- CONSTRUCTOR IDENTIFIERS ----
+isFileC :: DirTree a b -> Bool
+isFileC (File _ _) = True
+isFileC _          = False
+
+isDirC :: DirTree a b -> Bool
+isDirC (Dir _ _ _) = True
+isDirC _           = False
+
+
+---- PATH CONVERSIONS ----
+
+
+
+-- | tuple up the complete file path with the 'file' contents, by building up the
+-- path, trie-style, from the root. The filepath will be relative to \"anchored\"
+-- directory.
+--
+-- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of
+-- strings, although 'writeDirectory' does a better job of this.
+zipPaths :: AnchoredDirTree a b -> DirTree (FilePath, a) (FilePath, b)
+zipPaths (b :/ t) = zipP b t
+    where zipP p (File n a)   = File n (p</>n , a)
+          zipP p (Dir n cs a) = Dir n (map (zipP $ p</>n) cs) (p</>n , a)
+          zipP _ (Failed n e) = Failed n e
+
+
+-- extracting pathnames and base names:
+topDir, baseDir :: FilePath -> FilePath
+topDir = last . splitDirectories
+baseDir = joinPath . init . splitDirectories
+
+
+
+---- IO HELPERS: ----
+
+
+-- | writes the directory structure (not files) of a DirTree to the anchored
+-- directory. Returns a structure identical to the supplied tree with errors
+-- replaced by `Failed` constructors:
+writeJustDirs :: AnchoredDirTree a b -> IO (AnchoredDirTree () b)
+writeJustDirs = writeDirectoryWith (const return)
+
+
+----- the let expression is an annoying hack, because dropFileName "." == ""
+----- and getDirectoryContents fails epically on ""
+-- prepares the directory contents list. we sort so that we can be sure of
+-- a consistent fold/traversal order on the same directory:
+getDirsFiles :: String -> IO [FilePath]
+getDirsFiles cs = do let cs' = if null cs then "." else cs
+                     dfs <- getDirectoryContents cs'
+                     return $ dfs \\ [".",".."]
+
+
+readPath :: FilePath
+         -> IO (AnchoredDirTree DirTreeInfo DirTreeInfo)
+readPath = readDirectoryWithL mkDirInfo mkFileInfo
+
+
+mkFileInfo :: FilePath -> IO DirTreeInfo
+mkFileInfo fp =
+  FileInfo
+    <$> getPermissions      fp
+    <*> getCreationTime     fp
+    <*> getChangeTime       fp
+    <*> getModificationTime fp
+    <*> getAccessTime       fp
+    <*> isSymlink           fp
+    <*> getFileSize         fp
+
+
+mkDirInfo :: FilePath -> IO DirTreeInfo
+mkDirInfo fp =
+  DirInfo
+    <$> getPermissions      fp
+    <*> getCreationTime     fp
+    <*> getChangeTime       fp
+    <*> getModificationTime fp
+    <*> getAccessTime       fp
+    <*> isSymlink           fp
+    <*> hasSubDirectories   fp
+
+
+getFreeVar :: DirTree a a -> Maybe a
+getFreeVar (File _ f)  = Just f
+getFreeVar (Dir _ _ d) = Just d
+getFreeVar _           = Nothing
+
+
+---- FAILURE HELPERS: ----
+
+
+-- handles an IO exception by returning a Failed constructor filled with that
+-- exception:
+handleDT :: FileName -> IO (DirTree a b) -> IO (DirTree a b)
+handleDT n = handle (return . Failed n)
+
+
+-- 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 :: DirTree a b -> DirTree a b
+removeNonexistent = filterDir isOkConstructor
+     where isOkConstructor c = not (failed c) || isOkError c
+           isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
+
+
+-- | At 'Dir' constructor, apply transformation function to all of directory's
+-- contents, then remove the Nothing's and recurse. This always preserves the
+-- topomst constructor.
+transformDir :: (DirTree a b -> DirTree a b) -> DirTree a b -> DirTree a b
+transformDir f t = case f t of
+                     (Dir n cs a) -> Dir n (map (transformDir f) cs) a
+                     t'           -> t'
+
+
+
+---- OTHER: ----
+
+
+anchoredToPath :: AnchoredDirTree a b -> FilePath
+anchoredToPath a = anchor a </> (name . dirTree $ a)
+
+
+ls :: DirTree DirTreeInfo DirTreeInfo
+   -> [(FileName, String)]
+ls dt = fmap (\x -> (name x, packModTime x)) (contents dt)
+
+
+fromFreeVar :: (Default d) => (a -> d) -> DirTree a a -> d
+fromFreeVar f dt = maybeD f $ getFreeVar dt
+
+
+maybeD :: (Default b) => (a -> b) -> Maybe a -> b
+maybeD = maybe def
+
+
+-- |Pack the modification time
+packModTime :: DirTree DirTreeInfo DirTreeInfo
+            -> String
+packModTime = fromFreeVar
+                $ formatTime defaultTimeLocale rfc822DateFormat
+                . modTime
+
+
+packPermissions :: DirTree DirTreeInfo DirTreeInfo
+                -> String
+packPermissions dt = fromFreeVar (pStr . permissions) dt
+  where
+    pStr perm =    str perm readable   "r"
+                ++ str perm writable   "w"
+                ++ str perm (if isDirC dt then searchable else executable)
+                            "x"
+    str perm f ch
+      | f perm    = ch
+      | otherwise = "-"

src/Data/DirTree/Zipper.hs

@@ -0,0 +1,178 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module Data.DirTree.Zipper where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  )
+import Control.Arrow
+  (
+    first
+  )
+import Data.DirTree
+import System.Directory
+  (
+    canonicalizePath
+  )
+import System.FilePath
+ (
+    equalFilePath
+  , splitPath
+  , takeDirectory
+  , (</>)
+ )
+import System.IO.Unsafe
+  (
+    unsafeInterleaveIO
+  )
+import qualified Data.List as DL
+
+
+    ----------------------------
+    --[ ZIPPING ]--
+    ----------------------------
+
+
+-- |The zipper type, left is the (current) directory, right
+-- are the breadcrumbs.
+type DTZipper a b = (DirTree a b, [DirTree a b])
+
+
+-- |The base zipper of a tree with empty crumbs element.
+baseZipper :: DirTree a b -> DTZipper a b
+baseZipper dt = (dt, [])
+
+
+-- |Goes down the given subdir or file in a given directory. Returns `Nothing`
+-- if the subdir or file does not exist.
+--
+-- Note that this function can be slow, so it's not supposed to be called
+-- over a list of zippers. Use `goAllDown` instead.
+goDown :: FileName -> DTZipper a b -> Maybe (DTZipper a b)
+goDown ['.'] dtz      = Just dtz
+goDown ['.', '.'] dtz = Just $ goUp dtz
+goDown fn (dtp@(Dir n cs d), xs) =
+  case mcdt of
+    Just cdt -> Just (cdt, Dir n (crumb' fn cs) d : xs)
+    Nothing  -> Nothing
+  where
+    mcdt  = DL.find (\x -> equalFilePath (name x) fn) cs
+goDown _ _            = Nothing
+
+
+-- |Goes down all subdirs of a given directory.
+goAllDown :: DTZipper a b -> [DTZipper a b]
+goAllDown (Dir n cs d, xs) = fmap (\x -> (x, Dir n (crumb x cs) d : xs)) cs
+goAllDown _                = []
+
+
+-- |Goes down the given subpath in a given directory. Returns `Nothing`
+-- if the subpath does not exist.
+goDown' :: FilePath -> DTZipper a b -> Maybe (DTZipper a b)
+goDown' fp dz = go (splitPath fp) dz
+  where
+    go []  dz      = Just dz
+    go (fn:fns) dz = goDown fn dz >>= go fns
+
+
+-- TODO: error handling if the parent of a file is a file too (wat?)
+-- |Goes up one directory. This cannot fail. If you call it on the
+-- root node of the zipper, you get it back untouched.
+goUp :: DTZipper a b -> DTZipper a b
+goUp dz@(_, [])            = dz
+goUp (dt, Dir n cs d : xs) = (Dir n (dt:cs) d, xs)
+
+
+-- |Goes up to the root directory/node of the zipper.
+goRoot :: DTZipper a b -> DTZipper a b
+goRoot dz@(_, []) = dz
+goRoot dz         = goRoot (goUp dz)
+
+
+-- |Gets the full path of the current directory in the zipper context.
+-- This might not be a real absolute filesystem path, because it depends
+-- on the zipper context.
+getFullPath :: DTZipper a b -> FilePath
+getFullPath dz@(dt, _:_) = getFullPath (goUp dz) </> name dt
+getFullPath    (dt, [])  = name dt
+
+
+-- |The zipper that describes the ".." file inside a directory. The name
+-- is set to ".." too.
+upDirZipper :: DTZipper a b -> DTZipper a b
+upDirZipper dz = zipMap (\x -> x { name = "..", contents = [] }) $ goUp dz
+
+
+-- |The zipper that describes the "." file inside a directory. The name
+-- is set to "." too.
+curDirZipper :: DTZipper a b -> DTZipper a b
+curDirZipper dz = zipMap (\x -> x { name = ".", contents = [] }) dz
+
+
+-- |Retrieve the (current) directory component from the zipper.
+unZip :: DTZipper a b -> DirTree a b
+unZip = fst
+
+
+-- |Retrieve the (current) directory component from the zipper and
+-- transform it to an `AnchoredDirTree`.
+unZip' :: DTZipper a b -> AnchoredDirTree a b
+unZip' dz@(dt, _) = (takeDirectory . getFullPath $ dz) :/ dt
+
+
+-- |Map a function over the (current) directory component of the zipper.
+zipMap :: (DirTree a b -> DirTree a b) -> DTZipper a b -> DTZipper a b
+zipMap = first
+
+
+-- |Creates a zipper at the given location with lazy breadcrumbs. That
+-- means it doesn't traverse to the destination directory through the whole
+-- tree.
+--
+-- This can throw an exception on `canonicalizePath`.
+--
+-- It uses `unsafeInterleaveIO` and `readDirectoryWithL` to achieve
+-- lazy traversal.
+zipLazy :: (FilePath -> IO a)  -- ^ builder function for the free dir var
+        -> (FilePath -> IO b)  -- ^ builder function for the free file var
+        -> FilePath            -- ^ file path to drop to
+        -> IO (DTZipper a b)
+zipLazy fd ff fp = do
+  dt <- dirTree <$> readDirectoryWithL fd ff fp
+  go dt fp
+  where
+    go dt fp' = do
+      -- TODO: I hope parentDir doesn't blow up
+      parentDir <- canonicalizePath (fp' ++ "/..")
+      if fp' == parentDir
+         then return $ baseZipper dt
+         else do
+           -- HERE IS THE UNSAFE CODE:
+           crumbs <- unsafeInterleaveIO $ crumbrec parentDir
+           return (dt, crumbs)
+      where
+        crumbrec pD = do
+          pdt@(Dir n cs d) <- dirTree <$> readDirectoryWithL fd ff pD
+          (_, pc) <- go pdt pD
+          return $ Dir n (crumb dt cs) d : pc
+
+
+readPath' :: FilePath -> IO (DTZipper DirTreeInfo DirTreeInfo)
+readPath' = zipLazy mkDirInfo mkFileInfo
+
+
+    ---------------
+    --[ HELPERS ]--
+    ---------------
+
+
+crumb :: DirTree a b -> [DirTree a b] -> [DirTree a b]
+crumb dt cs = crumb' (name dt) cs
+
+
+crumb' :: FileName -> [DirTree a b] -> [DirTree a b]
+crumb' fn cs =
+  foldr (\x y -> if equalFilePath fn (name x) then y else x : y)
+        [] cs

src/GUI/Gtk.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module Main where
+
+import Graphics.UI.Gtk
+import GUI.Gtk.Gui
+
+main :: IO ()
+main = do
+  _ <- initGUI
+
+  startMainWindow
+
+  mainGUI

src/GUI/Gtk/Callbacks.hs

@@ -0,0 +1,3 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Callbacks (startGUI) where

src/GUI/Gtk/Gui.hs

@@ -0,0 +1,424 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Gui (startMainWindow) where
+
+
+import Control.Applicative
+  (
+    (<$>)
+  , (<*>)
+  )
+import Control.Concurrent
+  (
+    forkIO
+  )
+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.DirTree.Zipper
+import Data.Foldable
+  (
+    for_
+  )
+import Data.List
+  (
+    sort
+  , isPrefixOf
+  )
+import Data.Maybe
+  (
+    fromJust
+  , catMaybes
+  )
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Abstract.Box
+import Graphics.UI.Gtk.Builder
+import Graphics.UI.Gtk.ModelView
+import GUI.Gtk.Icons
+import IO.Error
+import IO.File
+import IO.Utils
+import System.Directory
+  (
+    executable
+  , doesFileExist
+  , doesDirectoryExist
+  )
+import System.Environment
+  (
+    getArgs
+  )
+import System.FilePath.Posix
+  (
+    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
+
+
+-- |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
+  , menubarFileCut :: ImageMenuItem
+  , menubarFileCopy :: ImageMenuItem
+  , menubarFilePaste :: ImageMenuItem
+  , menubarFileDelete :: ImageMenuItem
+  , menubarHelpAbout :: ImageMenuItem
+  , urlBar :: Entry
+  -- |tree view
+  , treeView :: TreeView
+  -- |first column
+  , cF :: TreeViewColumn
+  -- |second column
+  , cMD :: TreeViewColumn
+  -- |renderer used for the treeView
+  , renderTxt :: CellRendererText
+  , renderPix :: CellRendererPixbuf
+  , settings :: TVar FMSettings
+  , folderPix :: Pixbuf
+  , filePix :: Pixbuf
+  , errorPix :: Pixbuf
+}
+
+
+-- |FM-wide settings.
+data FMSettings = MkFMSettings {
+    showHidden :: Bool
+  , isLazy :: Bool
+}
+
+
+-- |This describes the contents of the treeView and is separated from MyGUI,
+-- because we might want to have multiple views.
+data MyView = MkMyView {
+  -- |raw model with unsorted data
+    rawModel :: TVar (ListStore (DTZipper DirTreeInfo DirTreeInfo))
+  -- |sorted proxy model
+  , sortedModel :: TVar (TypedTreeModelSort
+                          (DTZipper DirTreeInfo DirTreeInfo))
+  -- |filtered proxy model
+  , filteredModel :: TVar (TypedTreeModelFilter
+                            (DTZipper DirTreeInfo DirTreeInfo))
+  , fsState :: TVar (DTZipper DirTreeInfo DirTreeInfo)
+}
+
+
+-- |Set hotkeys.
+setBindings :: MyGUI -> MyView -> IO ()
+setBindings mygui myview = do
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "q"       <- fmap glibToString eventKeyName
+    liftIO mainQuit
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "h"       <- fmap glibToString eventKeyName
+    liftIO $ modifyTVarIO (settings mygui)
+                          (\x -> x { showHidden = not . showHidden $ x})
+             >> updateTreeView mygui myview
+  _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
+    [Alt] <- eventModifier
+    "Up"  <- fmap glibToString eventKeyName
+    liftIO $ upDir mygui myview
+  _ <- treeView mygui `on` rowActivated $ openRow mygui myview
+  _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
+  _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
+  return ()
+
+
+-- |Go the the url given at the `urlBar` and visualize it in the given
+-- treeView.
+--
+-- This might update the TVar `rawModel`.
+urlGoTo :: MyGUI -> MyView -> IO ()
+urlGoTo mygui myview = do
+  fp <- entryGetText (urlBar mygui)
+  let abs = isAbsolute fp
+  exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
+  -- TODO: more explicit error handling?
+  when (abs && exists) $ do
+    newFsState  <- readPath' fp
+    newRawModel <- fileListStore newFsState myview
+    writeTVarIO (rawModel myview) newRawModel
+    updateTreeView mygui myview
+
+
+-- |Enter a subdirectory and visualize it in the treeView or
+-- open a file.
+--
+-- This might update the TVar `rawModel`.
+openRow :: MyGUI -> MyView -> TreePath -> TreeViewColumn -> IO ()
+openRow mygui myview tp tvc = do
+  rawModel'      <- readTVarIO $ rawModel myview
+  sortedModel'   <- readTVarIO $ sortedModel myview
+  filteredModel' <- readTVarIO $ filteredModel myview
+  miter          <- treeModelGetIter sortedModel' tp
+  for_ miter $ \iter -> do
+    cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
+    cIter  <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
+    row    <- treeModelGetRow rawModel' cIter
+    case row of
+      (Dir _ _ _, _) -> do
+        newRawModel <- fileListStore row myview
+        rm <- readTVarIO (rawModel myview)
+        writeTVarIO (rawModel myview) newRawModel
+        updateTreeView mygui myview
+      dz@(File _ _, _) ->
+        withErrorDialog $ openFile (getFullPath dz)
+      _ -> return ()
+
+
+-- |Go up one directory and visualize it in the treeView.
+--
+-- This will update the TVar `rawModel`.
+upDir :: MyGUI -> MyView -> IO ()
+upDir mygui myview = do
+  rawModel'    <- readTVarIO $ rawModel myview
+  sortedModel' <- readTVarIO $ sortedModel myview
+  fS           <- readTVarIO $ fsState myview
+  newRawModel  <- fileListStore (goUp fS) myview
+  writeTVarIO (rawModel myview) newRawModel
+  updateTreeView 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.
+--
+-- This also updates the TVar `fsState` inside the given view.
+fileListStore :: DTZipper DirTreeInfo DirTreeInfo  -- ^ current dir
+              -> MyView
+              -> IO (ListStore (DTZipper DirTreeInfo DirTreeInfo))
+fileListStore dtz myview = do
+  writeTVarIO (fsState myview) dtz
+  listStoreNew (goAllDown dtz)
+
+
+-- TODO: make this function more slim so only the most necessary parts are
+-- called
+-- |Updates the visible TreeView with the current underlying mutable models,
+-- which are retrieved from `MyGUI`.
+--
+-- This also updates the TVars `filteredModel` and `sortedModel` in the process.
+updateTreeView :: MyGUI
+               -> MyView
+               -> IO ()
+updateTreeView mygui myview = do
+  let treeView' = treeView mygui
+      cF' = cF mygui
+      cMD' = cMD mygui
+      render' = renderTxt mygui
+
+  -- update urlBar, this will break laziness slightly, probably
+  fsState <- readTVarIO $ fsState myview
+  let urlpath = getFullPath fsState
+  entrySetText (urlBar mygui) urlpath
+
+  rawModel' <- readTVarIO $ rawModel myview
+
+  -- filtering
+  filteredModel' <- treeModelFilterNew rawModel' []
+  writeTVarIO (filteredModel myview) filteredModel'
+  treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
+     hidden <- showHidden <$> readTVarIO (settings mygui)
+     row    <- treeModelGetRow rawModel' iter
+     if hidden
+       then return True
+       else return $ not ("." `isPrefixOf` (name . unZip $ 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 (unZip row1) (unZip row2)
+  treeSortableSetSortColumnId sortedModel' 1 SortAscending
+
+  -- set values
+  treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
+                               (dirtreePix . unZip)
+  treeModelSetColumn rawModel' (makeColumnIdString 1)
+                               (name . unZip)
+  treeModelSetColumn rawModel' (makeColumnIdString 2)
+                               (packModTime . unZip)
+  treeModelSetColumn rawModel' (makeColumnIdString 3)
+                               (packPermissions . unZip)
+
+  -- update treeview model
+  treeViewSetModel treeView' sortedModel'
+
+  return ()
+  where
+    dirtreePix (Dir {})    = folderPix mygui
+    dirtreePix (File {})   = filePix mygui
+    dirtreePix (Failed {}) = errorPix mygui
+
+
+-- |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
+
+
+-- |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
+
+
+-- |Set up the GUI.
+startMainWindow :: IO ()
+startMainWindow = do
+
+  settings <- newTVarIO (MkFMSettings False True)
+
+  -- get the icons
+  iT        <- iconThemeGetDefault
+  folderPix <- getIcon IFolder 24
+  filePix   <- getIcon IFile 24
+  errorPix  <- getIcon IError 24
+
+  fsState <- readPath "/" >>= (newTVarIO . baseZipper . dirTree)
+
+  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"
+  menubarFileCut    <- builderGetObject builder castToImageMenuItem
+                       "menubarFileCut"
+  menubarFileCopy   <- builderGetObject builder castToImageMenuItem
+                       "menubarFileCopy"
+  menubarFilePaste  <- builderGetObject builder castToImageMenuItem
+                       "menubarFilePaste"
+  menubarFileDelete <- builderGetObject builder castToImageMenuItem
+                      "menubarFileDelete"
+  menubarHelpAbout  <- builderGetObject builder castToImageMenuItem
+                      "menubarHelpAbout"
+  urlBar <- builderGetObject builder castToEntry "urlBar"
+
+  -- create initial list store model with unsorted data
+  rawModel <- newTVarIO =<< listStoreNew . goAllDown =<< readTVarIO fsState
+
+  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
+  updateTreeView mygui myview
+
+  -- set the bindings
+  setBindings mygui myview
+
+  -- add the treeview to the scroll container
+  containerAdd scroll treeView
+
+  widgetShowAll rootWin

src/GUI/Gtk/Icons.hs

@@ -0,0 +1,31 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module GUI.Gtk.Icons where
+
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Gdk.Pixbuf
+
+
+-- |Icon type we use in our GUI.
+data GtkIcon = IFolder
+             | 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
+        -> Int        -- ^ requested icon size
+        -> IO Pixbuf
+getIcon icon isize = do
+  let iname = iconToStr icon
+  iT <- iconThemeGetDefault
+  mpix <- iconThemeLoadIcon iT iname isize IconLookupUseBuiltin
+  case mpix of
+    Just pix -> return pix
+    Nothing  -> pixbufNewFromFile ("data/Gtk/icons/" ++ iname)
+  where
+    iconToStr IFolder = "gtk-directory"
+    iconToStr IFile   = "gtk-file"
+    iconToStr IError  = "error"

src/IO/Error.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module IO.Error where
+
+
+import Control.Exception
+import Control.Monad
+  (
+    mzero
+  , MonadPlus
+  )
+import Data.Typeable
+
+
+data FmIOException = FileDoesNotExist String
+                   | PathNotAbsolute String
+                   | FileNotExecutable String
+  deriving (Show, Typeable)
+
+
+instance Exception FmIOException
+

src/IO/File.hs

@@ -0,0 +1,68 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module IO.File (
+    openFile
+  , executeFile
+  ) where
+
+
+import Control.Exception
+  (
+    throw
+  )
+import Control.Monad
+  (
+    unless
+  , void
+  )
+import IO.Error
+import System.Directory
+  (
+    doesFileExist
+  , getPermissions
+  , executable
+  )
+import System.FilePath.Posix
+  (
+    isAbsolute
+  )
+import System.Process
+  (
+    spawnProcess
+  , ProcessHandle
+  )
+
+
+-- |Opens a file appropriately by invoking xdg-open.
+--
+-- This will throw an exception if the filepath is not absolute
+-- or the file does not exist.
+openFile :: FilePath          -- ^ absolute path to file
+         -> IO ProcessHandle
+openFile fp = do
+  fileSanityThrow fp
+  spawnProcess "xdg-open" [fp]
+
+
+-- |Executes a program with the given arguments.
+--
+-- This will throw an exception if the filepath is not absolute
+-- or the file does not exist. It will also throw an exception
+-- if the file is not executable.
+executeFile :: FilePath          -- ^ absolute path to program
+            -> [String]          -- ^ arguments
+            -> IO ProcessHandle
+executeFile fp args = do
+  fileSanityThrow fp
+  p <- getPermissions fp
+  unless (executable p) (throw $ FileNotExecutable fp)
+  spawnProcess fp args
+
+
+-- Throws an exception if the filepath is not absolute
+-- or the file does not exist.
+fileSanityThrow :: FilePath -> IO ()
+fileSanityThrow fp = do
+  unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
+  exists <- doesFileExist fp
+  unless exists (throw $ FileDoesNotExist fp)

src/IO/Utils.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module IO.Utils where
+
+
+import Control.Concurrent.STM
+  (
+    atomically
+  )
+import Control.Concurrent.STM.TVar
+  (
+    writeTVar
+  , modifyTVar
+  , TVar
+  )
+
+
+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