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:
parent
5bfea0db10
commit
fe6145d5be
@ -22,6 +22,7 @@ library
|
||||
IO.Utils
|
||||
IO.File
|
||||
IO.Error
|
||||
MyPrelude
|
||||
|
||||
build-depends: base >= 4.7,
|
||||
data-default,
|
||||
@ -50,6 +51,7 @@ executable hsfm-gtk
|
||||
GUI.Gtk.Gui
|
||||
GUI.Gtk.Icons
|
||||
GUI.Gtk.Utils
|
||||
MyPrelude
|
||||
build-depends: hsfm,
|
||||
base >= 4.7,
|
||||
containers,
|
||||
|
||||
@ -32,7 +32,6 @@ import Control.Monad.State.Lazy
|
||||
|
||||
)
|
||||
import Data.Default
|
||||
import Data.IntMap.Lazy (IntMap)
|
||||
import Data.List
|
||||
(
|
||||
delete
|
||||
@ -61,6 +60,10 @@ import Data.Word
|
||||
(
|
||||
Word64
|
||||
)
|
||||
import Safe
|
||||
(
|
||||
atDef
|
||||
)
|
||||
import System.Directory
|
||||
(
|
||||
doesFileExist
|
||||
@ -77,6 +80,7 @@ import System.FilePath
|
||||
, equalFilePath
|
||||
, joinPath
|
||||
, splitDirectories
|
||||
, takeFileName
|
||||
, (</>)
|
||||
)
|
||||
import System.IO
|
||||
@ -117,7 +121,6 @@ import qualified Data.Bifoldable as BFL
|
||||
import qualified Data.Traversable as T
|
||||
import qualified System.Posix.Files as PF
|
||||
import qualified System.Posix.Directory as PFD
|
||||
import qualified Data.IntMap.Lazy as IM
|
||||
|
||||
|
||||
|
||||
@ -131,10 +134,10 @@ import qualified Data.IntMap.Lazy as IM
|
||||
type FileName = String
|
||||
|
||||
|
||||
-- |Represents a directory with it's contents (one level only), while
|
||||
-- preserving the context via the anchor.
|
||||
data AnchoredDirFile a b =
|
||||
(:/) { anchor :: FilePath, dirTree :: IntMap (DirFile a b) }
|
||||
-- |Represents a file. The `anchor` field is the path
|
||||
-- to that file without the filename.
|
||||
data AnchoredFile a b =
|
||||
(:/) { anchor :: FilePath, file :: File a b }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
@ -143,7 +146,7 @@ data AnchoredDirFile a b =
|
||||
-- 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 DirFile a b =
|
||||
data File a b =
|
||||
Failed {
|
||||
name :: FileName
|
||||
, err :: IOException
|
||||
@ -152,9 +155,9 @@ data DirFile a b =
|
||||
name :: FileName
|
||||
, dir :: a
|
||||
}
|
||||
| File {
|
||||
| RegFile {
|
||||
name :: FileName
|
||||
, file :: b
|
||||
, regFile :: b
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
@ -192,19 +195,19 @@ data FileInfo = FileInfo {
|
||||
----------------------------
|
||||
|
||||
|
||||
instance BF.Bifunctor DirFile where
|
||||
instance BF.Bifunctor File where
|
||||
bimap = BT.bimapDefault
|
||||
|
||||
|
||||
instance BFL.Bifoldable DirFile where
|
||||
instance BFL.Bifoldable File where
|
||||
bifoldMap = BT.bifoldMapDefault
|
||||
|
||||
|
||||
instance BT.Bitraversable DirFile where
|
||||
instance BT.Bitraversable File where
|
||||
bitraverse f1 f2 (Dir n b) =
|
||||
Dir n <$> f1 b
|
||||
bitraverse _ f2 (File n a) =
|
||||
File n <$> f2 a
|
||||
bitraverse _ f2 (RegFile n a) =
|
||||
RegFile n <$> f2 a
|
||||
bitraverse _ _ (Failed n e) =
|
||||
pure (Failed n e)
|
||||
|
||||
@ -213,8 +216,8 @@ instance BT.Bitraversable DirFile where
|
||||
-- | 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 (DirFile a b) where
|
||||
compare (File n a) (File n' a') =
|
||||
instance (Ord a, Ord b, Eq a, Eq b) => Ord (File a b) where
|
||||
compare (RegFile n a) (RegFile n' a') =
|
||||
case compare n n' of
|
||||
EQ -> compare a a'
|
||||
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
|
||||
-- using readFile.
|
||||
-- Uses `readDirectoryWith` internally and has the effect of traversing the
|
||||
-- entire directory structure. See `readDirectoryWithL` for lazy production
|
||||
-- of a DirFile structure.
|
||||
readDirectory :: FilePath -> IO (AnchoredDirFile String String)
|
||||
readDirectory = readDirectoryWith readFile return
|
||||
-- |Read a file into an `AnchoredFile`, filling the free variables via
|
||||
-- `getFileInfo`. This also works on directories, but doesn't look at
|
||||
-- their contents.
|
||||
readFileWith :: (FilePath -> IO a)
|
||||
-> (FilePath -> IO b)
|
||||
-> FilePath
|
||||
-> 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
|
||||
@ -249,7 +272,7 @@ readDirectory = readDirectoryWith readFile return
|
||||
readDirectoryWith :: (FilePath -> IO a)
|
||||
-> (FilePath -> IO b)
|
||||
-> FilePath
|
||||
-> IO (AnchoredDirFile a b)
|
||||
-> IO [AnchoredFile a b]
|
||||
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 Failed constructor. The 'file' fields initially are populated with full
|
||||
-- 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
|
||||
-- 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 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"
|
||||
-- nature of traversing a system firectory tree:
|
||||
@ -283,10 +306,10 @@ buildWith' :: Builder a b
|
||||
-> UserIO a
|
||||
-> UserIO b
|
||||
-> FilePath
|
||||
-> IO (AnchoredDirFile a b)
|
||||
-> IO [AnchoredFile a b]
|
||||
buildWith' 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
|
||||
do isFile <- doesFileExist subf
|
||||
if isFile
|
||||
then File n <$> ff subf
|
||||
then RegFile n <$> ff subf
|
||||
else Dir n <$> fd subf
|
||||
|
||||
|
||||
@ -314,22 +337,22 @@ buildAtOnce' fd ff p = do
|
||||
|
||||
|
||||
-- | True if any Failed constructors in the tree
|
||||
anyFailed :: [DirFile a b] -> Bool
|
||||
anyFailed :: [File a b] -> Bool
|
||||
anyFailed = not . successful
|
||||
|
||||
-- | True if there are no Failed constructors in the tree
|
||||
successful :: [DirFile a b] -> Bool
|
||||
successful :: [File a b] -> Bool
|
||||
successful = null . failures
|
||||
|
||||
|
||||
-- | returns true if argument is a `Failed` constructor:
|
||||
failed :: DirFile a b -> Bool
|
||||
failed :: File a b -> Bool
|
||||
failed (Failed _ _) = True
|
||||
failed _ = False
|
||||
|
||||
|
||||
-- | returns a list of 'Failed' constructors only:
|
||||
failures :: [DirFile a b] -> [DirFile a b]
|
||||
failures :: [File a b] -> [File a b]
|
||||
failures = filter failed
|
||||
|
||||
|
||||
@ -339,27 +362,27 @@ failures = filter failed
|
||||
|
||||
-- | 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 :: DirFile a b -> DirFile c d -> Bool
|
||||
equalShape :: File a b -> File 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 :: DirFile a b -> DirFile c d -> Ordering
|
||||
comparingShape :: File a b -> File c d -> Ordering
|
||||
comparingShape (Dir n _) (Dir n' _) = compare n n'
|
||||
-- else simply compare the flat constructors, non-recursively:
|
||||
comparingShape t t' = comparingConstr t t'
|
||||
|
||||
|
||||
-- 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 _ _) (File _ _) = LT
|
||||
comparingConstr (File _ _) (Failed _ _) = GT
|
||||
comparingConstr (File _ _) (Dir _ _) = GT
|
||||
comparingConstr (Failed _ _) (RegFile _ _) = LT
|
||||
comparingConstr (RegFile _ _) (Failed _ _) = GT
|
||||
comparingConstr (RegFile _ _) (Dir _ _) = 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
|
||||
-- looking at the contents of Dir constructors:
|
||||
comparingConstr t t' = compare (name t) (name t')
|
||||
@ -377,11 +400,11 @@ comparingConstr t t' = compare (name t) (name t')
|
||||
|
||||
|
||||
---- CONSTRUCTOR IDENTIFIERS ----
|
||||
isFileC :: DirFile a b -> Bool
|
||||
isFileC (File _ _) = True
|
||||
isFileC :: File a b -> Bool
|
||||
isFileC (RegFile _ _) = True
|
||||
isFileC _ = False
|
||||
|
||||
isDirC :: DirFile a b -> Bool
|
||||
isDirC :: File a b -> Bool
|
||||
isDirC (Dir _ _) = True
|
||||
isDirC _ = False
|
||||
|
||||
@ -400,37 +423,38 @@ baseDir = joinPath . init . splitDirectories
|
||||
---- 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 ""
|
||||
-- prepares the directory contents list. we sort so that we can be sure of
|
||||
-- a consistent fold/traversal order on the same directory:
|
||||
getDirsFiles :: FilePath -> IO (IntMap FilePath)
|
||||
|
||||
getContents :: AnchoredFile FileInfo FileInfo
|
||||
-> IO [AnchoredFile FileInfo FileInfo]
|
||||
getContents (bp :/ Dir n _) = readDirectory (bp </> n)
|
||||
getContents _ = return []
|
||||
|
||||
|
||||
-- |Get all files of a given directory and return them as a List.
|
||||
getDirsFiles :: FilePath -> IO [FilePath]
|
||||
getDirsFiles fp = do
|
||||
dirstream <- PFD.openDirStream fp
|
||||
let mdirs :: Int -> IntMap FilePath -> IO (IntMap FilePath)
|
||||
mdirs ix dirs = do
|
||||
let mdirs :: [FilePath] -> IO [FilePath]
|
||||
mdirs dirs = do
|
||||
dir <- PFD.readDirStream dirstream
|
||||
if dir == ""
|
||||
then return dirs
|
||||
else mdirs (ix + 1) (instertF ix dir dirs)
|
||||
dirs <- mdirs 0 IM.empty
|
||||
else mdirs (instert dir dirs)
|
||||
dirs <- mdirs []
|
||||
PFD.closeDirStream dirstream
|
||||
return dirs
|
||||
where
|
||||
instertF ix dir dirs = case dir of
|
||||
instert dir dirs = case dir of
|
||||
"." -> 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.
|
||||
getFileInfo :: FilePath -> IO FileInfo
|
||||
@ -463,8 +487,8 @@ getFileInfo fp = do
|
||||
|
||||
|
||||
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
|
||||
getFreeVar :: DirFile a a -> Maybe a
|
||||
getFreeVar (File _ f) = Just f
|
||||
getFreeVar :: File a a -> Maybe a
|
||||
getFreeVar (RegFile _ f) = Just f
|
||||
getFreeVar (Dir _ d) = Just d
|
||||
getFreeVar _ = Nothing
|
||||
|
||||
@ -474,7 +498,7 @@ getFreeVar _ = Nothing
|
||||
|
||||
-- handles an IO exception by returning a Failed constructor filled with that
|
||||
-- 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)
|
||||
|
||||
|
||||
@ -484,8 +508,8 @@ handleDT n = handle (return . Failed n)
|
||||
-- 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 :: IntMap (DirFile a b) -> IntMap (DirFile a b)
|
||||
removeNonexistent = IM.filter isOkConstructor
|
||||
removeNonexistent :: [File a b] -> [File a b]
|
||||
removeNonexistent = filter isOkConstructor
|
||||
where isOkConstructor c = not (failed c) || isOkError c
|
||||
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
|
||||
|
||||
@ -495,20 +519,11 @@ removeNonexistent = IM.filter isOkConstructor
|
||||
---- OTHER: ----
|
||||
|
||||
|
||||
-- TODO: use Maybe type?
|
||||
dirLookup :: AnchoredDirFile a b -> Int -> DirFile a b
|
||||
dirLookup df ix =
|
||||
fromMaybe errTree (IM.lookup ix . dirTree $ df)
|
||||
where
|
||||
errTree = Failed "Not found!!!"
|
||||
(userError $ "Failed to lookup index " ++ show ix)
|
||||
fullPath :: AnchoredFile a b -> FilePath
|
||||
fullPath (bp :/ f) = bp </> name f
|
||||
|
||||
|
||||
subDirName :: AnchoredDirFile a b -> Int -> FilePath
|
||||
subDirName df ix = anchor df </> name (dirLookup df ix)
|
||||
|
||||
|
||||
fromFreeVar :: (Default d) => (a -> d) -> DirFile a a -> d
|
||||
fromFreeVar :: (Default d) => (a -> d) -> File a a -> d
|
||||
fromFreeVar f df = maybeD f $ getFreeVar df
|
||||
|
||||
|
||||
@ -517,12 +532,12 @@ maybeD = maybe def
|
||||
|
||||
|
||||
-- |Pack the modification time
|
||||
packModTime :: DirFile FileInfo FileInfo
|
||||
packModTime :: File FileInfo FileInfo
|
||||
-> String
|
||||
packModTime = fromFreeVar
|
||||
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
|
||||
|
||||
packPermissions :: DirFile FileInfo FileInfo
|
||||
packPermissions :: File FileInfo FileInfo
|
||||
-> String
|
||||
packPermissions dt = fromFreeVar (pStr . permissions) dt
|
||||
where
|
||||
|
||||
@ -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
|
||||
open :: Row -> MyGUI -> MyView -> IO ()
|
||||
open row mygui myview = do
|
||||
fS <- readTVarIO $ fsState myview
|
||||
case IM.lookup row (dirTree fS) of
|
||||
Just dt@(Dir n _) -> do
|
||||
newP <- readPath (anchor fS </> n)
|
||||
refreshTreeView' mygui myview newP
|
||||
Just dt@(File n _) ->
|
||||
withErrorDialog $ openFile (anchor fS </> n)
|
||||
open row mygui myview =
|
||||
case row of
|
||||
r@(_ :/ Dir _ _) -> do
|
||||
nv <- Data.DirTree.readFile $ fullPath r
|
||||
refreshTreeView' mygui myview nv
|
||||
r@(_ :/ RegFile _ _) ->
|
||||
withErrorDialog $ openFile $ fullPath r
|
||||
_ -> return ()
|
||||
|
||||
|
||||
@ -124,24 +121,23 @@ open row mygui myview = do
|
||||
--
|
||||
-- * 'fsState' reads
|
||||
del :: Row -> MyGUI -> MyView -> IO ()
|
||||
del row mygui myview = do
|
||||
fS <- readTVarIO $ fsState myview
|
||||
case dirLookup fS row of
|
||||
dt@(Dir n _) -> do
|
||||
let fp = anchor fS </> n
|
||||
subADT <- readPath fp
|
||||
del row mygui myview =
|
||||
case row of
|
||||
r@(_ :/ Dir _ _) -> do
|
||||
let fp = fullPath r
|
||||
subADT <- readDirectory fp
|
||||
let cmsg = "Really delete directory \"" ++ fp ++ "\"?"
|
||||
cmsg2 = "Directory \"" ++ fp ++
|
||||
"\" is not empty! Delete all contents?"
|
||||
withConfirmationDialog cmsg $
|
||||
if IM.null (dirTree subADT)
|
||||
if null subADT
|
||||
then withErrorDialog (deleteDir fp
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
else withConfirmationDialog cmsg2 $ withErrorDialog
|
||||
(deleteDirRecursive fp
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
dt@(File _ _) -> do
|
||||
let fp = subDirName fS row
|
||||
r@(_ :/ RegFile _ _) -> do
|
||||
let fp = fullPath r
|
||||
cmsg = "Really delete file \"" ++ fp ++ "\"?"
|
||||
withConfirmationDialog cmsg
|
||||
$ withErrorDialog (deleteFile fp
|
||||
@ -155,9 +151,8 @@ del row mygui myview = do
|
||||
-- * 'operationBuffer' writes
|
||||
-- * 'fsState' reads
|
||||
copyInit :: Row -> MyGUI -> MyView -> IO ()
|
||||
copyInit row mygui myview = do
|
||||
fsState <- readTVarIO $ fsState myview
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ subDirName fsState row)
|
||||
copyInit row mygui myview =
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ fullPath row)
|
||||
|
||||
|
||||
-- |Finalizes a file copy operation.
|
||||
@ -171,7 +166,7 @@ copyFinal mygui myview = do
|
||||
op <- readTVarIO (operationBuffer myview)
|
||||
case op of
|
||||
FCopy (CP1 source) -> do
|
||||
dest <- anchor <$> readTVarIO (fsState myview)
|
||||
dest <- fullPath <$> readTVarIO (fsState myview)
|
||||
isFile <- doesFileExist source
|
||||
let cmsg = "Really copy file \"" ++ source
|
||||
++ "\"" ++ " to \"" ++ dest ++ "\"?"
|
||||
@ -194,5 +189,5 @@ upDir mygui myview = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
sortedModel' <- readTVarIO $ sortedModel myview
|
||||
fS <- readTVarIO $ fsState myview
|
||||
newP <- readPath (baseDir . anchor $ fS)
|
||||
refreshTreeView' mygui myview newP
|
||||
nv <- goUp fS
|
||||
refreshTreeView' mygui myview nv
|
||||
|
||||
@ -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,
|
||||
@ -65,7 +65,7 @@ data MyView = MkMyView {
|
||||
rawModel :: TVar (ListStore Row)
|
||||
, sortedModel :: TVar (TypedTreeModelSort Row)
|
||||
, filteredModel :: TVar (TypedTreeModelFilter Row)
|
||||
, fsState :: TVar (AnchoredDirFile FileInfo FileInfo)
|
||||
, fsState :: TVar (AnchoredFile FileInfo FileInfo)
|
||||
, operationBuffer :: TVar FileOperation
|
||||
}
|
||||
|
||||
|
||||
@ -63,6 +63,7 @@ import GUI.Gtk.Utils
|
||||
import IO.Error
|
||||
import IO.File
|
||||
import IO.Utils
|
||||
import MyPrelude
|
||||
import System.Directory
|
||||
(
|
||||
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
|
||||
@ -130,7 +129,7 @@ startMainWindow startdir = do
|
||||
filePix <- getIcon IFile 24
|
||||
errorPix <- getIcon IError 24
|
||||
|
||||
fsState <- readPath startdir >>= newTVarIO
|
||||
fsState <- Data.DirTree.readFile startdir >>= newTVarIO
|
||||
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
@ -162,7 +161,8 @@ startMainWindow startdir = do
|
||||
"statusBar"
|
||||
|
||||
-- create initial list store model with unsorted data
|
||||
rawModel <- newTVarIO =<< listStoreNew . IM.keys . dirTree
|
||||
rawModel <- newTVarIO =<< listStoreNew
|
||||
=<< Data.DirTree.getContents
|
||||
=<< readTVarIO fsState
|
||||
|
||||
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
|
||||
|
||||
@ -34,10 +34,9 @@ import Graphics.UI.Gtk
|
||||
import GUI.Gtk.Data
|
||||
import IO.Error
|
||||
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:
|
||||
--
|
||||
-- * 'fsState' writes
|
||||
fileListStore :: AnchoredDirFile FileInfo FileInfo -- ^ current dir
|
||||
fileListStore :: AnchoredFile FileInfo FileInfo -- ^ current dir
|
||||
-> MyView
|
||||
-> IO (ListStore Row)
|
||||
fileListStore dt myview = do
|
||||
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.
|
||||
@ -114,13 +114,13 @@ refreshTreeView :: MyGUI
|
||||
-> IO ()
|
||||
refreshTreeView mygui myview mfp = do
|
||||
fsState <- readTVarIO $ fsState myview
|
||||
let cfp = anchor fsState
|
||||
let cfp = fullPath fsState
|
||||
fp = fromMaybe cfp mfp
|
||||
|
||||
-- TODO catch exceptions
|
||||
dirSanityThrow fp
|
||||
|
||||
newFsState <- readPath fp
|
||||
newFsState <- Data.DirTree.readFile fp
|
||||
newRawModel <- fileListStore newFsState myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
constructTreeView mygui myview
|
||||
@ -133,7 +133,7 @@ refreshTreeView mygui myview mfp = do
|
||||
-- * 'rawModel' writes
|
||||
refreshTreeView' :: MyGUI
|
||||
-> MyView
|
||||
-> AnchoredDirFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> IO ()
|
||||
refreshTreeView' mygui myview dt = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
@ -163,10 +163,9 @@ constructTreeView mygui myview = do
|
||||
render' = renderTxt mygui
|
||||
|
||||
fsState <- readTVarIO $ fsState myview
|
||||
let dirL = dirLookup fsState
|
||||
|
||||
-- update urlBar, this will break laziness slightly, probably
|
||||
let urlpath = anchor fsState
|
||||
let urlpath = fullPath fsState
|
||||
entrySetText (urlBar mygui) urlpath
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
@ -176,7 +175,7 @@ constructTreeView mygui myview = do
|
||||
writeTVarIO (filteredModel myview) filteredModel'
|
||||
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
|
||||
hidden <- showHidden <$> readTVarIO (settings mygui)
|
||||
row <- (name . dirL) <$> treeModelGetRow rawModel' iter
|
||||
row <- (name . file) <$> treeModelGetRow rawModel' iter
|
||||
if hidden
|
||||
then return True
|
||||
else return $ not ("." `isPrefixOf` row)
|
||||
@ -187,20 +186,20 @@ constructTreeView mygui myview = do
|
||||
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
|
||||
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
|
||||
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
|
||||
row1 <- dirL <$> treeModelGetRow rawModel' cIter1
|
||||
row2 <- dirL <$> treeModelGetRow rawModel' cIter2
|
||||
row1 <- treeModelGetRow rawModel' cIter1
|
||||
row2 <- treeModelGetRow rawModel' cIter2
|
||||
return $ compare row1 row2
|
||||
treeSortableSetSortColumnId sortedModel' 1 SortAscending
|
||||
|
||||
-- set values
|
||||
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
|
||||
(dirtreePix . dirL)
|
||||
(dirtreePix . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 1)
|
||||
(name . dirL)
|
||||
(name . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 2)
|
||||
(packModTime . dirL)
|
||||
(packModTime . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 3)
|
||||
(packPermissions . dirL)
|
||||
(packPermissions . file)
|
||||
|
||||
-- update treeview model
|
||||
treeViewSetModel treeView' sortedModel'
|
||||
@ -208,7 +207,7 @@ constructTreeView mygui myview = do
|
||||
return ()
|
||||
where
|
||||
dirtreePix (Dir {}) = folderPix mygui
|
||||
dirtreePix (File {}) = filePix mygui
|
||||
dirtreePix (RegFile {}) = filePix mygui
|
||||
dirtreePix (Failed {}) = errorPix mygui
|
||||
|
||||
|
||||
|
||||
@ -67,6 +67,7 @@ import qualified System.Posix.Files as PF
|
||||
|
||||
-- TODO: modify the DTZipper directly after file operations!?
|
||||
-- TODO: file operations should be threaded and not block the UI
|
||||
-- TODO: canonicalize paths?
|
||||
|
||||
|
||||
-- |Data type describing an actual file operation that can be
|
||||
|
||||
9
src/MyPrelude.hs
Normal file
9
src/MyPrelude.hs
Normal file
@ -0,0 +1,9 @@
|
||||
module MyPrelude where
|
||||
|
||||
|
||||
import Data.List
|
||||
|
||||
|
||||
|
||||
listIndices :: [a] -> [Int]
|
||||
listIndices = findIndices (const True)
|
||||
Loading…
Reference in New Issue
Block a user