LIB/GTK: change DirTree again

we now have:
* AnchoredFile -- for representing a file with context
* File         -- for representing a file only

Both representations mean "file" in the broader sense, including
directories.
This commit is contained in:
Julian Ospald 2015-12-21 00:41:02 +01:00
parent 5bfea0db10
commit fe6145d5be
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
8 changed files with 157 additions and 136 deletions

View File

@ -22,6 +22,7 @@ library
IO.Utils IO.Utils
IO.File IO.File
IO.Error IO.Error
MyPrelude
build-depends: base >= 4.7, build-depends: base >= 4.7,
data-default, data-default,
@ -50,6 +51,7 @@ executable hsfm-gtk
GUI.Gtk.Gui GUI.Gtk.Gui
GUI.Gtk.Icons GUI.Gtk.Icons
GUI.Gtk.Utils GUI.Gtk.Utils
MyPrelude
build-depends: hsfm, build-depends: hsfm,
base >= 4.7, base >= 4.7,
containers, containers,

View File

@ -32,7 +32,6 @@ import Control.Monad.State.Lazy
) )
import Data.Default import Data.Default
import Data.IntMap.Lazy (IntMap)
import Data.List import Data.List
( (
delete delete
@ -61,6 +60,10 @@ import Data.Word
( (
Word64 Word64
) )
import Safe
(
atDef
)
import System.Directory import System.Directory
( (
doesFileExist doesFileExist
@ -77,6 +80,7 @@ import System.FilePath
, equalFilePath , equalFilePath
, joinPath , joinPath
, splitDirectories , splitDirectories
, takeFileName
, (</>) , (</>)
) )
import System.IO import System.IO
@ -117,7 +121,6 @@ import qualified Data.Bifoldable as BFL
import qualified Data.Traversable as T import qualified Data.Traversable as T
import qualified System.Posix.Files as PF import qualified System.Posix.Files as PF
import qualified System.Posix.Directory as PFD import qualified System.Posix.Directory as PFD
import qualified Data.IntMap.Lazy as IM
@ -131,10 +134,10 @@ import qualified Data.IntMap.Lazy as IM
type FileName = String type FileName = String
-- |Represents a directory with it's contents (one level only), while -- |Represents a file. The `anchor` field is the path
-- preserving the context via the anchor. -- to that file without the filename.
data AnchoredDirFile a b = data AnchoredFile a b =
(:/) { anchor :: FilePath, dirTree :: IntMap (DirFile a b) } (:/) { anchor :: FilePath, file :: File a b }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
@ -143,7 +146,7 @@ data AnchoredDirFile a b =
-- Handles, Strings representing a file's contents or anything else you can -- Handles, Strings representing a file's contents or anything else you can
-- think of. We catch any IO errors in the Failed constructor. an Exception -- think of. We catch any IO errors in the Failed constructor. an Exception
-- can be converted to a String with 'show'. -- can be converted to a String with 'show'.
data DirFile a b = data File a b =
Failed { Failed {
name :: FileName name :: FileName
, err :: IOException , err :: IOException
@ -152,9 +155,9 @@ data DirFile a b =
name :: FileName name :: FileName
, dir :: a , dir :: a
} }
| File { | RegFile {
name :: FileName name :: FileName
, file :: b , regFile :: b
} deriving (Show, Eq) } deriving (Show, Eq)
@ -192,19 +195,19 @@ data FileInfo = FileInfo {
---------------------------- ----------------------------
instance BF.Bifunctor DirFile where instance BF.Bifunctor File where
bimap = BT.bimapDefault bimap = BT.bimapDefault
instance BFL.Bifoldable DirFile where instance BFL.Bifoldable File where
bifoldMap = BT.bifoldMapDefault bifoldMap = BT.bifoldMapDefault
instance BT.Bitraversable DirFile where instance BT.Bitraversable File where
bitraverse f1 f2 (Dir n b) = bitraverse f1 f2 (Dir n b) =
Dir n <$> f1 b Dir n <$> f1 b
bitraverse _ f2 (File n a) = bitraverse _ f2 (RegFile n a) =
File n <$> f2 a RegFile n <$> f2 a
bitraverse _ _ (Failed n e) = bitraverse _ _ (Failed n e) =
pure (Failed n e) pure (Failed n e)
@ -213,8 +216,8 @@ instance BT.Bitraversable DirFile where
-- | First compare constructors: Failed < Dir < File... -- | First compare constructors: Failed < Dir < File...
-- Then compare `name`... -- Then compare `name`...
-- Then compare free variable parameter of `File` constructors -- Then compare free variable parameter of `File` constructors
instance (Ord a, Ord b, Eq a, Eq b) => Ord (DirFile a b) where instance (Ord a, Ord b, Eq a, Eq b) => Ord (File a b) where
compare (File n a) (File n' a') = compare (RegFile n a) (RegFile n' a') =
case compare n n' of case compare n n' of
EQ -> compare a a' EQ -> compare a a'
el -> el el -> el
@ -235,13 +238,33 @@ instance (Ord a, Ord b, Eq a, Eq b) => Ord (DirFile a b) where
---------------------------- ----------------------------
-- | build an AnchoredDirFile, given the path to a directory, opening the files -- |Read a file into an `AnchoredFile`, filling the free variables via
-- using readFile. -- `getFileInfo`. This also works on directories, but doesn't look at
-- Uses `readDirectoryWith` internally and has the effect of traversing the -- their contents.
-- entire directory structure. See `readDirectoryWithL` for lazy production readFileWith :: (FilePath -> IO a)
-- of a DirFile structure. -> (FilePath -> IO b)
readDirectory :: FilePath -> IO (AnchoredDirFile String String) -> FilePath
readDirectory = readDirectoryWith readFile return -> IO (AnchoredFile a b)
readFileWith fd ff fp = do
file <- handleDT fn $ do
isFile <- doesFileExist fp
if isFile
then RegFile fn <$> ff fp
else Dir fn <$> fd fp
return (bd :/ file)
where
fn = topDir fp
bd = baseDir fp
readFile :: FilePath -> IO (AnchoredFile FileInfo FileInfo)
readFile = readFileWith getFileInfo getFileInfo
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`.
readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo]
readDirectory = readDirectoryWith getFileInfo getFileInfo
-- | same as readDirectory but allows us to, for example, use -- | same as readDirectory but allows us to, for example, use
@ -249,7 +272,7 @@ readDirectory = readDirectoryWith readFile return
readDirectoryWith :: (FilePath -> IO a) readDirectoryWith :: (FilePath -> IO a)
-> (FilePath -> IO b) -> (FilePath -> IO b)
-> FilePath -> FilePath
-> IO (AnchoredDirFile a b) -> IO [AnchoredFile a b]
readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p
@ -261,11 +284,11 @@ readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p
-- | builds a DirFile from the contents of the directory passed to it, saving -- | builds a File 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 base directory in the Anchored* wrapper. Errors are caught in the tree in
-- the Failed constructor. The 'file' fields initially are populated with full -- the Failed constructor. The 'file' fields initially are populated with full
-- paths to the files they are abstracting. -- paths to the files they are abstracting.
build :: FilePath -> IO (AnchoredDirFile FilePath FilePath) build :: FilePath -> IO [AnchoredFile FilePath FilePath]
build = buildWith' buildAtOnce' return return -- we say 'return' here to get build = buildWith' buildAtOnce' return return -- we say 'return' here to get
-- back a tree of FilePaths -- back a tree of FilePaths
@ -275,7 +298,7 @@ build = buildWith' buildAtOnce' return return -- we say 'return' here to get
type UserIO a = FilePath -> IO a type UserIO a = FilePath -> IO a
type Builder a b = UserIO a -> UserIO b -> FilePath -> IO (IntMap (DirFile a b)) type Builder a b = UserIO a -> UserIO b -> FilePath -> IO [File a b]
-- remove non-existent file errors, which are artifacts of the "non-atomic" -- remove non-existent file errors, which are artifacts of the "non-atomic"
-- nature of traversing a system firectory tree: -- nature of traversing a system firectory tree:
@ -283,10 +306,10 @@ buildWith' :: Builder a b
-> UserIO a -> UserIO a
-> UserIO b -> UserIO b
-> FilePath -> FilePath
-> IO (AnchoredDirFile a b) -> IO [AnchoredFile a b]
buildWith' bf' fd ff p = buildWith' bf' fd ff p =
do tree <- bf' fd ff p do tree <- bf' fd ff p
return (p :/ removeNonexistent tree) return $ fmap (p :/) (removeNonexistent tree)
@ -298,7 +321,7 @@ buildAtOnce' fd ff p = do
let subf = p </> n let subf = p </> n
do isFile <- doesFileExist subf do isFile <- doesFileExist subf
if isFile if isFile
then File n <$> ff subf then RegFile n <$> ff subf
else Dir n <$> fd subf else Dir n <$> fd subf
@ -314,22 +337,22 @@ buildAtOnce' fd ff p = do
-- | True if any Failed constructors in the tree -- | True if any Failed constructors in the tree
anyFailed :: [DirFile a b] -> Bool anyFailed :: [File a b] -> Bool
anyFailed = not . successful anyFailed = not . successful
-- | True if there are no Failed constructors in the tree -- | True if there are no Failed constructors in the tree
successful :: [DirFile a b] -> Bool successful :: [File a b] -> Bool
successful = null . failures successful = null . failures
-- | returns true if argument is a `Failed` constructor: -- | returns true if argument is a `Failed` constructor:
failed :: DirFile a b -> Bool failed :: File a b -> Bool
failed (Failed _ _) = True failed (Failed _ _) = True
failed _ = False failed _ = False
-- | returns a list of 'Failed' constructors only: -- | returns a list of 'Failed' constructors only:
failures :: [DirFile a b] -> [DirFile a b] failures :: [File a b] -> [File a b]
failures = filter failed failures = filter failed
@ -339,27 +362,27 @@ failures = filter failed
-- | Tests equality of two trees, ignoring their free variable portion. Can be -- | 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. -- used to check if any files have been added or deleted, for instance.
equalShape :: DirFile a b -> DirFile c d -> Bool equalShape :: File a b -> File c d -> Bool
equalShape d d' = comparingShape d d' == EQ equalShape d d' = comparingShape d d' == EQ
-- TODO: we should use equalFilePath here, but how to sort properly? -- TODO: we should use equalFilePath here, but how to sort properly?
-- with System.Directory.canonicalizePath, before compare? -- with System.Directory.canonicalizePath, before compare?
-- | a compare function that ignores the free "file" type variable: -- | a compare function that ignores the free "file" type variable:
comparingShape :: DirFile a b -> DirFile c d -> Ordering comparingShape :: File a b -> File c d -> Ordering
comparingShape (Dir n _) (Dir n' _) = compare n n' comparingShape (Dir n _) (Dir n' _) = compare n n'
-- else simply compare the flat constructors, non-recursively: -- else simply compare the flat constructors, non-recursively:
comparingShape t t' = comparingConstr t t' comparingShape t t' = comparingConstr t t'
-- HELPER: a non-recursive comparison -- HELPER: a non-recursive comparison
comparingConstr :: DirFile a b -> DirFile a1 b1 -> Ordering comparingConstr :: File a b -> File a1 b1 -> Ordering
comparingConstr (Failed _ _) (Dir _ _) = LT comparingConstr (Failed _ _) (Dir _ _) = LT
comparingConstr (Failed _ _) (File _ _) = LT comparingConstr (Failed _ _) (RegFile _ _) = LT
comparingConstr (File _ _) (Failed _ _) = GT comparingConstr (RegFile _ _) (Failed _ _) = GT
comparingConstr (File _ _) (Dir _ _) = GT comparingConstr (RegFile _ _) (Dir _ _) = GT
comparingConstr (Dir _ _) (Failed _ _) = GT comparingConstr (Dir _ _) (Failed _ _) = GT
comparingConstr (Dir _ _) (File _ _) = LT comparingConstr (Dir _ _) (RegFile _ _) = LT
-- else compare on the names of constructors that are the same, without -- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors: -- looking at the contents of Dir constructors:
comparingConstr t t' = compare (name t) (name t') comparingConstr t t' = compare (name t) (name t')
@ -377,11 +400,11 @@ comparingConstr t t' = compare (name t) (name t')
---- CONSTRUCTOR IDENTIFIERS ---- ---- CONSTRUCTOR IDENTIFIERS ----
isFileC :: DirFile a b -> Bool isFileC :: File a b -> Bool
isFileC (File _ _) = True isFileC (RegFile _ _) = True
isFileC _ = False isFileC _ = False
isDirC :: DirFile a b -> Bool isDirC :: File a b -> Bool
isDirC (Dir _ _) = True isDirC (Dir _ _) = True
isDirC _ = False isDirC _ = False
@ -400,37 +423,38 @@ baseDir = joinPath . init . splitDirectories
---- IO HELPERS: ---- ---- IO HELPERS: ----
-- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo FileInfo -> IO (AnchoredFile FileInfo FileInfo)
goUp af@("" :/ _) = return af
goUp (bp :/ _) = Data.DirTree.readFile bp
----- the let expression is an annoying hack, because dropFileName "." == ""
----- and getDirectoryContents fails epically on "" getContents :: AnchoredFile FileInfo FileInfo
-- prepares the directory contents list. we sort so that we can be sure of -> IO [AnchoredFile FileInfo FileInfo]
-- a consistent fold/traversal order on the same directory: getContents (bp :/ Dir n _) = readDirectory (bp </> n)
getDirsFiles :: FilePath -> IO (IntMap FilePath) getContents _ = return []
-- |Get all files of a given directory and return them as a List.
getDirsFiles :: FilePath -> IO [FilePath]
getDirsFiles fp = do getDirsFiles fp = do
dirstream <- PFD.openDirStream fp dirstream <- PFD.openDirStream fp
let mdirs :: Int -> IntMap FilePath -> IO (IntMap FilePath) let mdirs :: [FilePath] -> IO [FilePath]
mdirs ix dirs = do mdirs dirs = do
dir <- PFD.readDirStream dirstream dir <- PFD.readDirStream dirstream
if dir == "" if dir == ""
then return dirs then return dirs
else mdirs (ix + 1) (instertF ix dir dirs) else mdirs (instert dir dirs)
dirs <- mdirs 0 IM.empty dirs <- mdirs []
PFD.closeDirStream dirstream PFD.closeDirStream dirstream
return dirs return dirs
where where
instertF ix dir dirs = case dir of instert dir dirs = case dir of
"." -> dirs "." -> dirs
".." -> dirs ".." -> dirs
_ -> IM.insert ix dir dirs _ -> dir : dirs
-- |Read a filepath and return transform it into our `AnchoredDirFile`
-- with the free variables of both the File and Dir constructors filled
-- with `FileInfo`.
readPath :: FilePath
-> IO (AnchoredDirFile FileInfo FileInfo)
readPath = readDirectoryWith getFileInfo getFileInfo
-- |Gets all file information. -- |Gets all file information.
getFileInfo :: FilePath -> IO FileInfo getFileInfo :: FilePath -> IO FileInfo
@ -463,10 +487,10 @@ getFileInfo fp = do
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`. -- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: DirFile a a -> Maybe a getFreeVar :: File a a -> Maybe a
getFreeVar (File _ f) = Just f getFreeVar (RegFile _ f) = Just f
getFreeVar (Dir _ d) = Just d getFreeVar (Dir _ d) = Just d
getFreeVar _ = Nothing getFreeVar _ = Nothing
---- FAILURE HELPERS: ---- ---- FAILURE HELPERS: ----
@ -474,7 +498,7 @@ getFreeVar _ = Nothing
-- handles an IO exception by returning a Failed constructor filled with that -- handles an IO exception by returning a Failed constructor filled with that
-- exception: -- exception:
handleDT :: FileName -> IO (DirFile a b) -> IO (DirFile a b) handleDT :: FileName -> IO (File a b) -> IO (File a b)
handleDT n = handle (return . Failed n) handleDT n = handle (return . Failed n)
@ -484,8 +508,8 @@ handleDT n = handle (return . Failed n)
-- So we filter those errors out because the user should not see errors -- So we filter those errors out because the user should not see errors
-- raised by the internal implementation of this module: -- raised by the internal implementation of this module:
-- This leaves the error if it exists in the top (user-supplied) level: -- This leaves the error if it exists in the top (user-supplied) level:
removeNonexistent :: IntMap (DirFile a b) -> IntMap (DirFile a b) removeNonexistent :: [File a b] -> [File a b]
removeNonexistent = IM.filter isOkConstructor removeNonexistent = filter isOkConstructor
where isOkConstructor c = not (failed c) || isOkError c where isOkConstructor c = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
@ -495,20 +519,11 @@ removeNonexistent = IM.filter isOkConstructor
---- OTHER: ---- ---- OTHER: ----
-- TODO: use Maybe type? fullPath :: AnchoredFile a b -> FilePath
dirLookup :: AnchoredDirFile a b -> Int -> DirFile a b fullPath (bp :/ f) = bp </> name f
dirLookup df ix =
fromMaybe errTree (IM.lookup ix . dirTree $ df)
where
errTree = Failed "Not found!!!"
(userError $ "Failed to lookup index " ++ show ix)
subDirName :: AnchoredDirFile a b -> Int -> FilePath fromFreeVar :: (Default d) => (a -> d) -> File a a -> d
subDirName df ix = anchor df </> name (dirLookup df ix)
fromFreeVar :: (Default d) => (a -> d) -> DirFile a a -> d
fromFreeVar f df = maybeD f $ getFreeVar df fromFreeVar f df = maybeD f $ getFreeVar df
@ -517,12 +532,12 @@ maybeD = maybe def
-- |Pack the modification time -- |Pack the modification time
packModTime :: DirFile FileInfo FileInfo packModTime :: File FileInfo FileInfo
-> String -> String
packModTime = fromFreeVar packModTime = fromFreeVar
$ show . posixSecondsToUTCTime . realToFrac . modificationTime $ show . posixSecondsToUTCTime . realToFrac . modificationTime
packPermissions :: DirFile FileInfo FileInfo packPermissions :: File FileInfo FileInfo
-> String -> String
packPermissions dt = fromFreeVar (pStr . permissions) dt packPermissions dt = fromFreeVar (pStr . permissions) dt
where where

View File

@ -41,8 +41,6 @@ import System.Glib.UTFString
) )
import qualified Data.IntMap.Lazy as IM
@ -107,14 +105,13 @@ urlGoTo mygui myview = do
-- --
-- * 'fsState' reads -- * 'fsState' reads
open :: Row -> MyGUI -> MyView -> IO () open :: Row -> MyGUI -> MyView -> IO ()
open row mygui myview = do open row mygui myview =
fS <- readTVarIO $ fsState myview case row of
case IM.lookup row (dirTree fS) of r@(_ :/ Dir _ _) -> do
Just dt@(Dir n _) -> do nv <- Data.DirTree.readFile $ fullPath r
newP <- readPath (anchor fS </> n) refreshTreeView' mygui myview nv
refreshTreeView' mygui myview newP r@(_ :/ RegFile _ _) ->
Just dt@(File n _) -> withErrorDialog $ openFile $ fullPath r
withErrorDialog $ openFile (anchor fS </> n)
_ -> return () _ -> return ()
@ -124,24 +121,23 @@ open row mygui myview = do
-- --
-- * 'fsState' reads -- * 'fsState' reads
del :: Row -> MyGUI -> MyView -> IO () del :: Row -> MyGUI -> MyView -> IO ()
del row mygui myview = do del row mygui myview =
fS <- readTVarIO $ fsState myview case row of
case dirLookup fS row of r@(_ :/ Dir _ _) -> do
dt@(Dir n _) -> do let fp = fullPath r
let fp = anchor fS </> n subADT <- readDirectory fp
subADT <- readPath fp
let cmsg = "Really delete directory \"" ++ fp ++ "\"?" let cmsg = "Really delete directory \"" ++ fp ++ "\"?"
cmsg2 = "Directory \"" ++ fp ++ cmsg2 = "Directory \"" ++ fp ++
"\" is not empty! Delete all contents?" "\" is not empty! Delete all contents?"
withConfirmationDialog cmsg $ withConfirmationDialog cmsg $
if IM.null (dirTree subADT) if null subADT
then withErrorDialog (deleteDir fp then withErrorDialog (deleteDir fp
>> refreshTreeView mygui myview Nothing) >> refreshTreeView mygui myview Nothing)
else withConfirmationDialog cmsg2 $ withErrorDialog else withConfirmationDialog cmsg2 $ withErrorDialog
(deleteDirRecursive fp (deleteDirRecursive fp
>> refreshTreeView mygui myview Nothing) >> refreshTreeView mygui myview Nothing)
dt@(File _ _) -> do r@(_ :/ RegFile _ _) -> do
let fp = subDirName fS row let fp = fullPath r
cmsg = "Really delete file \"" ++ fp ++ "\"?" cmsg = "Really delete file \"" ++ fp ++ "\"?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ withErrorDialog (deleteFile fp $ withErrorDialog (deleteFile fp
@ -155,9 +151,8 @@ del row mygui myview = do
-- * 'operationBuffer' writes -- * 'operationBuffer' writes
-- * 'fsState' reads -- * 'fsState' reads
copyInit :: Row -> MyGUI -> MyView -> IO () copyInit :: Row -> MyGUI -> MyView -> IO ()
copyInit row mygui myview = do copyInit row mygui myview =
fsState <- readTVarIO $ fsState myview writeTVarIO (operationBuffer myview) (FCopy . CP1 $ fullPath row)
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ subDirName fsState row)
-- |Finalizes a file copy operation. -- |Finalizes a file copy operation.
@ -171,7 +166,7 @@ copyFinal mygui myview = do
op <- readTVarIO (operationBuffer myview) op <- readTVarIO (operationBuffer myview)
case op of case op of
FCopy (CP1 source) -> do FCopy (CP1 source) -> do
dest <- anchor <$> readTVarIO (fsState myview) dest <- fullPath <$> readTVarIO (fsState myview)
isFile <- doesFileExist source isFile <- doesFileExist source
let cmsg = "Really copy file \"" ++ source let cmsg = "Really copy file \"" ++ source
++ "\"" ++ " to \"" ++ dest ++ "\"?" ++ "\"" ++ " to \"" ++ dest ++ "\"?"
@ -194,5 +189,5 @@ upDir mygui myview = do
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview sortedModel' <- readTVarIO $ sortedModel myview
fS <- readTVarIO $ fsState myview fS <- readTVarIO $ fsState myview
newP <- readPath (baseDir . anchor $ fS) nv <- goUp fS
refreshTreeView' mygui myview newP refreshTreeView' mygui myview nv

View File

@ -56,7 +56,7 @@ data FMSettings = MkFMSettings {
} }
type Row = Int type Row = AnchoredFile FileInfo FileInfo
-- |This describes the contents of the treeView and is separated from MyGUI, -- |This describes the contents of the treeView and is separated from MyGUI,
@ -65,7 +65,7 @@ data MyView = MkMyView {
rawModel :: TVar (ListStore Row) rawModel :: TVar (ListStore Row)
, sortedModel :: TVar (TypedTreeModelSort Row) , sortedModel :: TVar (TypedTreeModelSort Row)
, filteredModel :: TVar (TypedTreeModelFilter Row) , filteredModel :: TVar (TypedTreeModelFilter Row)
, fsState :: TVar (AnchoredDirFile FileInfo FileInfo) , fsState :: TVar (AnchoredFile FileInfo FileInfo)
, operationBuffer :: TVar FileOperation , operationBuffer :: TVar FileOperation
} }

View File

@ -63,6 +63,7 @@ import GUI.Gtk.Utils
import IO.Error import IO.Error
import IO.File import IO.File
import IO.Utils import IO.Utils
import MyPrelude
import System.Directory import System.Directory
( (
executable executable
@ -92,8 +93,6 @@ import System.Process
) )
import Data.IntMap.Lazy (IntMap)
import qualified Data.IntMap.Lazy as IM
-- TODO: simplify where we modify the TVars -- TODO: simplify where we modify the TVars
@ -130,7 +129,7 @@ startMainWindow startdir = do
filePix <- getIcon IFile 24 filePix <- getIcon IFile 24
errorPix <- getIcon IError 24 errorPix <- getIcon IError 24
fsState <- readPath startdir >>= newTVarIO fsState <- Data.DirTree.readFile startdir >>= newTVarIO
operationBuffer <- newTVarIO None operationBuffer <- newTVarIO None
@ -162,7 +161,8 @@ startMainWindow startdir = do
"statusBar" "statusBar"
-- create initial list store model with unsorted data -- create initial list store model with unsorted data
rawModel <- newTVarIO =<< listStoreNew . IM.keys . dirTree rawModel <- newTVarIO =<< listStoreNew
=<< Data.DirTree.getContents
=<< readTVarIO fsState =<< readTVarIO fsState
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x []) filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])

View File

@ -34,10 +34,9 @@ import Graphics.UI.Gtk
import GUI.Gtk.Data import GUI.Gtk.Data
import IO.Error import IO.Error
import IO.Utils import IO.Utils
import MyPrelude
import qualified Data.IntMap.Lazy as IM
----------------- -----------------
@ -89,12 +88,13 @@ withRow mygui myview io = do
-- Interaction with mutable references: -- Interaction with mutable references:
-- --
-- * 'fsState' writes -- * 'fsState' writes
fileListStore :: AnchoredDirFile FileInfo FileInfo -- ^ current dir fileListStore :: AnchoredFile FileInfo FileInfo -- ^ current dir
-> MyView -> MyView
-> IO (ListStore Row) -> IO (ListStore Row)
fileListStore dt myview = do fileListStore dt myview = do
writeTVarIO (fsState myview) dt writeTVarIO (fsState myview) dt
listStoreNew (IM.keys . dirTree $ dt) cs <- Data.DirTree.getContents dt
listStoreNew cs
-- |Re-reads the current directory or the given one and updates the TreeView. -- |Re-reads the current directory or the given one and updates the TreeView.
@ -114,13 +114,13 @@ refreshTreeView :: MyGUI
-> IO () -> IO ()
refreshTreeView mygui myview mfp = do refreshTreeView mygui myview mfp = do
fsState <- readTVarIO $ fsState myview fsState <- readTVarIO $ fsState myview
let cfp = anchor fsState let cfp = fullPath fsState
fp = fromMaybe cfp mfp fp = fromMaybe cfp mfp
-- TODO catch exceptions -- TODO catch exceptions
dirSanityThrow fp dirSanityThrow fp
newFsState <- readPath fp newFsState <- Data.DirTree.readFile fp
newRawModel <- fileListStore newFsState myview newRawModel <- fileListStore newFsState myview
writeTVarIO (rawModel myview) newRawModel writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview constructTreeView mygui myview
@ -133,7 +133,7 @@ refreshTreeView mygui myview mfp = do
-- * 'rawModel' writes -- * 'rawModel' writes
refreshTreeView' :: MyGUI refreshTreeView' :: MyGUI
-> MyView -> MyView
-> AnchoredDirFile FileInfo FileInfo -> AnchoredFile FileInfo FileInfo
-> IO () -> IO ()
refreshTreeView' mygui myview dt = do refreshTreeView' mygui myview dt = do
newRawModel <- fileListStore dt myview newRawModel <- fileListStore dt myview
@ -163,10 +163,9 @@ constructTreeView mygui myview = do
render' = renderTxt mygui render' = renderTxt mygui
fsState <- readTVarIO $ fsState myview fsState <- readTVarIO $ fsState myview
let dirL = dirLookup fsState
-- update urlBar, this will break laziness slightly, probably -- update urlBar, this will break laziness slightly, probably
let urlpath = anchor fsState let urlpath = fullPath fsState
entrySetText (urlBar mygui) urlpath entrySetText (urlBar mygui) urlpath
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview
@ -176,7 +175,7 @@ constructTreeView mygui myview = do
writeTVarIO (filteredModel myview) filteredModel' writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui) hidden <- showHidden <$> readTVarIO (settings mygui)
row <- (name . dirL) <$> treeModelGetRow rawModel' iter row <- (name . file) <$> treeModelGetRow rawModel' iter
if hidden if hidden
then return True then return True
else return $ not ("." `isPrefixOf` row) else return $ not ("." `isPrefixOf` row)
@ -187,29 +186,29 @@ constructTreeView mygui myview = do
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1 cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2 cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
row1 <- dirL <$> treeModelGetRow rawModel' cIter1 row1 <- treeModelGetRow rawModel' cIter1
row2 <- dirL <$> treeModelGetRow rawModel' cIter2 row2 <- treeModelGetRow rawModel' cIter2
return $ compare row1 row2 return $ compare row1 row2
treeSortableSetSortColumnId sortedModel' 1 SortAscending treeSortableSetSortColumnId sortedModel' 1 SortAscending
-- set values -- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0) treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . dirL) (dirtreePix . file)
treeModelSetColumn rawModel' (makeColumnIdString 1) treeModelSetColumn rawModel' (makeColumnIdString 1)
(name . dirL) (name . file)
treeModelSetColumn rawModel' (makeColumnIdString 2) treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . dirL) (packModTime . file)
treeModelSetColumn rawModel' (makeColumnIdString 3) treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . dirL) (packPermissions . file)
-- update treeview model -- update treeview model
treeViewSetModel treeView' sortedModel' treeViewSetModel treeView' sortedModel'
return () return ()
where where
dirtreePix (Dir {}) = folderPix mygui dirtreePix (Dir {}) = folderPix mygui
dirtreePix (File {}) = filePix mygui dirtreePix (RegFile {}) = filePix mygui
dirtreePix (Failed {}) = errorPix mygui dirtreePix (Failed {}) = errorPix mygui
-- |Push a message to the status bar. -- |Push a message to the status bar.

View File

@ -67,6 +67,7 @@ import qualified System.Posix.Files as PF
-- TODO: modify the DTZipper directly after file operations!? -- TODO: modify the DTZipper directly after file operations!?
-- TODO: file operations should be threaded and not block the UI -- TODO: file operations should be threaded and not block the UI
-- TODO: canonicalize paths?
-- |Data type describing an actual file operation that can be -- |Data type describing an actual file operation that can be

9
src/MyPrelude.hs Normal file
View File

@ -0,0 +1,9 @@
module MyPrelude where
import Data.List
listIndices :: [a] -> [Int]
listIndices = findIndices (const True)