2015-12-19 15:13:48 +00:00
|
|
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
|
|
|
|
module GUI.Gtk.Utils where
|
|
|
|
|
|
|
|
|
|
|
|
import Control.Applicative
|
|
|
|
(
|
|
|
|
(<$>)
|
|
|
|
)
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
(
|
|
|
|
TVar
|
|
|
|
, newTVarIO
|
|
|
|
, readTVarIO
|
|
|
|
)
|
|
|
|
import Data.DirTree
|
|
|
|
import Data.Foldable
|
|
|
|
(
|
|
|
|
for_
|
|
|
|
)
|
|
|
|
import Data.List
|
|
|
|
(
|
|
|
|
isPrefixOf
|
|
|
|
)
|
|
|
|
import Data.Maybe
|
|
|
|
(
|
|
|
|
fromMaybe
|
2015-12-21 04:41:12 +00:00
|
|
|
, fromJust
|
2015-12-19 15:13:48 +00:00
|
|
|
)
|
|
|
|
import Data.Traversable
|
|
|
|
(
|
|
|
|
forM
|
|
|
|
)
|
|
|
|
import Graphics.UI.Gtk
|
|
|
|
import GUI.Gtk.Data
|
|
|
|
import IO.Error
|
|
|
|
import IO.Utils
|
2015-12-20 23:41:02 +00:00
|
|
|
import MyPrelude
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-----------------
|
|
|
|
--[ Utilities ]--
|
|
|
|
-----------------
|
|
|
|
|
|
|
|
|
|
|
|
-- |Gets the currently selected row of the treeView, if any.
|
|
|
|
--
|
|
|
|
-- Interaction with mutable references:
|
|
|
|
--
|
|
|
|
-- * 'rawModel' reads
|
|
|
|
-- * 'sortedModel' reads
|
|
|
|
-- * 'filteredModel' reads
|
|
|
|
getSelectedRow :: MyGUI
|
|
|
|
-> MyView
|
|
|
|
-> IO (Maybe Row)
|
|
|
|
getSelectedRow mygui myview = do
|
|
|
|
(tp, _) <- treeViewGetCursor $ treeView mygui
|
|
|
|
rawModel' <- readTVarIO $ rawModel myview
|
|
|
|
sortedModel' <- readTVarIO $ sortedModel myview
|
|
|
|
filteredModel' <- readTVarIO $ filteredModel myview
|
|
|
|
miter <- treeModelGetIter sortedModel' tp
|
|
|
|
forM miter $ \iter -> do
|
|
|
|
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
|
|
|
|
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
|
|
|
|
treeModelGetRow rawModel' cIter
|
|
|
|
|
|
|
|
|
|
|
|
-- |Carry out an action on the currently selected row.
|
|
|
|
--
|
|
|
|
-- If there is no row selected, does nothing.
|
|
|
|
withRow :: MyGUI
|
|
|
|
-> MyView
|
|
|
|
-> ( Row
|
|
|
|
-> MyGUI
|
|
|
|
-> MyView
|
|
|
|
-> IO ()) -- ^ action to carry out
|
|
|
|
-> IO ()
|
|
|
|
withRow mygui myview io = do
|
|
|
|
mrow <- getSelectedRow mygui myview
|
|
|
|
for_ mrow $ \row -> io row mygui myview
|
|
|
|
|
|
|
|
|
|
|
|
-- |Create the 'ListStore' of files/directories from the current directory.
|
|
|
|
-- This is the function which maps the Data.DirTree data structures
|
|
|
|
-- into the GTK+ data structures.
|
2015-12-20 23:41:02 +00:00
|
|
|
fileListStore :: AnchoredFile FileInfo FileInfo -- ^ current dir
|
2015-12-19 15:13:48 +00:00
|
|
|
-> MyView
|
|
|
|
-> IO (ListStore Row)
|
|
|
|
fileListStore dt myview = do
|
2015-12-20 23:41:02 +00:00
|
|
|
cs <- Data.DirTree.getContents dt
|
|
|
|
listStoreNew cs
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
|
2015-12-21 04:41:12 +00:00
|
|
|
-- |Currently unsafe. This is used to obtain any row (possibly the '.' row)
|
|
|
|
-- and extract the "current working directory" from it.
|
|
|
|
--
|
|
|
|
-- Interaction with mutable references:
|
|
|
|
--
|
|
|
|
-- * 'rawModel' reads
|
2015-12-22 13:15:48 +00:00
|
|
|
getFirstRow :: MyView
|
|
|
|
-> IO (AnchoredFile FileInfo FileInfo)
|
|
|
|
getFirstRow myview = do
|
2015-12-21 04:41:12 +00:00
|
|
|
rawModel' <- readTVarIO $ rawModel myview
|
|
|
|
iter <- fromJust <$> treeModelGetIterFirst rawModel'
|
2015-12-22 13:15:48 +00:00
|
|
|
treeModelGetRow rawModel' iter
|
2015-12-21 04:41:12 +00:00
|
|
|
|
|
|
|
|
2015-12-19 15:13:48 +00:00
|
|
|
-- |Re-reads the current directory or the given one and updates the TreeView.
|
|
|
|
--
|
|
|
|
-- The operation may fail with:
|
|
|
|
--
|
|
|
|
-- * 'DirDoesNotExist' if the target directory does not exist
|
|
|
|
-- * 'PathNotAbsolute' if the target directory is not absolute
|
|
|
|
--
|
|
|
|
-- Interaction with mutable references:
|
|
|
|
--
|
|
|
|
-- * 'rawModel' writes
|
|
|
|
refreshTreeView :: MyGUI
|
|
|
|
-> MyView
|
|
|
|
-> Maybe FilePath
|
|
|
|
-> IO ()
|
|
|
|
refreshTreeView mygui myview mfp = do
|
2015-12-22 13:15:48 +00:00
|
|
|
mcdir <- getFirstRow myview
|
|
|
|
let fp = fromMaybe (anchor mcdir) mfp
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
-- TODO catch exceptions
|
|
|
|
dirSanityThrow fp
|
|
|
|
|
2015-12-20 23:41:02 +00:00
|
|
|
newFsState <- Data.DirTree.readFile fp
|
2015-12-19 15:13:48 +00:00
|
|
|
newRawModel <- fileListStore newFsState myview
|
|
|
|
writeTVarIO (rawModel myview) newRawModel
|
|
|
|
constructTreeView mygui myview
|
|
|
|
|
|
|
|
|
|
|
|
-- |Refreshes the TreeView based on the given directory.
|
|
|
|
--
|
|
|
|
-- Interaction with mutable references:
|
|
|
|
--
|
|
|
|
-- * 'rawModel' writes
|
|
|
|
refreshTreeView' :: MyGUI
|
|
|
|
-> MyView
|
2015-12-20 23:41:02 +00:00
|
|
|
-> AnchoredFile FileInfo FileInfo
|
2015-12-19 15:13:48 +00:00
|
|
|
-> IO ()
|
|
|
|
refreshTreeView' mygui myview dt = do
|
|
|
|
newRawModel <- fileListStore dt myview
|
|
|
|
writeTVarIO (rawModel myview) newRawModel
|
|
|
|
constructTreeView mygui myview
|
|
|
|
|
|
|
|
|
|
|
|
-- TODO: make this function more slim so only the most necessary parts are
|
|
|
|
-- called
|
|
|
|
-- |Constructs the visible TreeView with the current underlying mutable models,
|
|
|
|
-- which are retrieved from 'MyGUI'.
|
|
|
|
--
|
|
|
|
-- Interaction with mutable references:
|
|
|
|
--
|
|
|
|
-- * 'rawModel' reads
|
|
|
|
-- * 'filteredModel' writes
|
|
|
|
-- * 'sortedModel' writes
|
|
|
|
-- * 'settings' reads
|
|
|
|
constructTreeView :: MyGUI
|
|
|
|
-> MyView
|
|
|
|
-> IO ()
|
|
|
|
constructTreeView mygui myview = do
|
|
|
|
let treeView' = treeView mygui
|
|
|
|
cF' = cF mygui
|
|
|
|
cMD' = cMD mygui
|
|
|
|
render' = renderTxt mygui
|
|
|
|
|
2015-12-22 13:15:48 +00:00
|
|
|
mcdir <- getFirstRow myview
|
2015-12-19 15:13:48 +00:00
|
|
|
|
2015-12-21 04:41:12 +00:00
|
|
|
-- update urlBar
|
2015-12-22 13:15:48 +00:00
|
|
|
entrySetText (urlBar mygui) (anchor mcdir)
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
rawModel' <- readTVarIO $ rawModel myview
|
|
|
|
|
|
|
|
-- filtering
|
|
|
|
filteredModel' <- treeModelFilterNew rawModel' []
|
|
|
|
writeTVarIO (filteredModel myview) filteredModel'
|
|
|
|
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
|
|
|
|
hidden <- showHidden <$> readTVarIO (settings mygui)
|
2015-12-20 23:41:02 +00:00
|
|
|
row <- (name . file) <$> treeModelGetRow rawModel' iter
|
2015-12-19 15:13:48 +00:00
|
|
|
if hidden
|
|
|
|
then return True
|
2015-12-21 04:41:12 +00:00
|
|
|
else return $ not . hiddenFile $ row
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
-- sorting
|
|
|
|
sortedModel' <- treeModelSortNewWithModel filteredModel'
|
|
|
|
writeTVarIO (sortedModel myview) sortedModel'
|
|
|
|
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
|
|
|
|
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
|
|
|
|
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
|
2015-12-20 23:41:02 +00:00
|
|
|
row1 <- treeModelGetRow rawModel' cIter1
|
|
|
|
row2 <- treeModelGetRow rawModel' cIter2
|
2015-12-19 15:13:48 +00:00
|
|
|
return $ compare row1 row2
|
|
|
|
treeSortableSetSortColumnId sortedModel' 1 SortAscending
|
|
|
|
|
|
|
|
-- set values
|
|
|
|
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
|
2015-12-20 23:41:02 +00:00
|
|
|
(dirtreePix . file)
|
2015-12-19 15:13:48 +00:00
|
|
|
treeModelSetColumn rawModel' (makeColumnIdString 1)
|
2015-12-20 23:41:02 +00:00
|
|
|
(name . file)
|
2015-12-19 15:13:48 +00:00
|
|
|
treeModelSetColumn rawModel' (makeColumnIdString 2)
|
2015-12-20 23:41:02 +00:00
|
|
|
(packModTime . file)
|
2015-12-19 15:13:48 +00:00
|
|
|
treeModelSetColumn rawModel' (makeColumnIdString 3)
|
2015-12-20 23:41:02 +00:00
|
|
|
(packPermissions . file)
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
-- update treeview model
|
|
|
|
treeViewSetModel treeView' sortedModel'
|
|
|
|
|
|
|
|
return ()
|
|
|
|
where
|
2015-12-20 23:41:02 +00:00
|
|
|
dirtreePix (Dir {}) = folderPix mygui
|
|
|
|
dirtreePix (RegFile {}) = filePix mygui
|
|
|
|
dirtreePix (Failed {}) = errorPix mygui
|
2015-12-19 15:13:48 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Push a message to the status bar.
|
|
|
|
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
|
|
|
|
pushStatusBar mygui str = do
|
|
|
|
let sb = statusBar mygui
|
|
|
|
cid <- statusbarGetContextId sb "FM Status"
|
|
|
|
mid <- statusbarPush sb cid str
|
|
|
|
return (cid, mid)
|