module HSFM.GUI.Gtk.MyView where
import Control.Concurrent.MVar
(
newEmptyMVar
, putMVar
, tryTakeMVar
)
import Control.Concurrent.STM
(
newTVarIO
, readTVarIO
)
import Control.Exception
(
try
, SomeException
)
import Control.Monad
(
forM_
)
import qualified Data.ByteString as BS
import Data.Foldable
(
for_
)
import Data.Maybe
(
catMaybes
, fromJust
)
import HPath.IO.Errors
(
canOpenDirectory
)
import Graphics.UI.Gtk
import HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
import HPath
(
Path
, Abs
)
import qualified HPath as P
import HSFM.FileSystem.FileType
import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import Paths_hsfm
(
getDataFileName
)
import Prelude hiding(readFile)
import System.INotify
(
addWatch
, initINotify
, killINotify
, EventVariety(..)
)
import System.Posix.FilePath
(
pathSeparator
, hiddenFile
)
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
newTab mygui iofmv path = do
myview <- createMyView mygui iofmv
i <- notebookAppendPage (notebook mygui) (viewBox myview)
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
mpage <- notebookGetNthPage (notebook mygui) i
forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
page
True
refreshView mygui myview (Just path)
return myview
createMyView :: MyGUI
-> IO FMView
-> IO MyView
createMyView mygui iofmv = do
inotify <- newEmptyMVar
history <- newTVarIO ([],[])
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
rawModel <- newTVarIO =<< listStoreNew []
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
=<< readTVarIO rawModel
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
=<< readTVarIO filteredModel
cwd <- newEmptyMVar
view' <- iofmv
view <- newTVarIO view'
urlBar <- builderGetObject builder castToEntry
"urlBar"
rcMenu <- builderGetObject builder castToMenu
"rcMenu"
rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
"rcFileNewRegFile"
rcFileNewDir <- builderGetObject builder castToImageMenuItem
"rcFileNewDir"
rcFileCut <- builderGetObject builder castToImageMenuItem
"rcFileCut"
rcFileCopy <- builderGetObject builder castToImageMenuItem
"rcFileCopy"
rcFileRename <- builderGetObject builder castToImageMenuItem
"rcFileRename"
rcFilePaste <- builderGetObject builder castToImageMenuItem
"rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete"
rcFileProperty <- builderGetObject builder castToImageMenuItem
"rcFileProperty"
rcFileIconView <- builderGetObject builder castToImageMenuItem
"rcFileIconView"
rcFileTreeView <- builderGetObject builder castToImageMenuItem
"rcFileTreeView"
upViewB <- builderGetObject builder castToButton
"upViewB"
homeViewB <- builderGetObject builder castToButton
"homeViewB"
refreshViewB <- builderGetObject builder castToButton
"refreshViewB"
scroll <- builderGetObject builder castToScrolledWindow
"mainScroll"
viewBox <- builderGetObject builder castToBox
"viewBox"
let rcmenu = MkRightClickMenu {..}
let myview = MkMyView {..}
setViewCallbacks mygui myview
let oview = fmViewToContainer view'
containerAdd scroll oview
widgetShowAll viewBox
return myview
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
switchView mygui myview iofmv = do
cwd <- getCurrentDir myview
oldpage <- destroyView mygui myview
nview <- createMyView mygui iofmv
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
(maybe (P.fromAbs $ path cwd) P.fromRel
$ P.basename . path $ cwd) oldpage
notebookSetCurrentPage (notebook mygui) newpage
refreshView' mygui nview cwd
destroyView :: MyGUI -> MyView -> IO Int
destroyView mygui myview = do
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
page <- notebookGetCurrentPage (notebook mygui)
view' <- readTVarIO $ view myview
widgetDestroy (fmViewToContainer view')
notebookRemovePage (notebook mygui) page
return page
createIconView :: IO FMView
createIconView = do
iconv <- iconViewNew
iconViewSetSelectionMode iconv SelectionMultiple
iconViewSetColumns iconv (1)
iconViewSetSpacing iconv 2
iconViewSetMargin iconv 0
return $ FMIconView iconv
createTreeView :: IO FMView
createTreeView = do
treeView <- treeViewNew
tvs <- treeViewGetSelection treeView
treeSelectionSetMode tvs SelectionMultiple
tl <- targetListNew
atom <- atomNew ("HSFM" :: String)
targetListAdd tl atom [TargetSameApp] 0
treeViewEnableModelDragDest treeView tl [ActionCopy]
treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy]
renderTxt <- cellRendererTextNew
renderPix <- cellRendererPixbufNew
let ct = cellText :: (CellRendererTextClass cr) => Attr cr String
cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
cF <- treeViewColumnNew
treeViewColumnSetTitle cF ("Filename" :: String)
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
cMD <- treeViewColumnNew
treeViewColumnSetTitle cMD ("Date" :: String)
treeViewColumnSetResizable cMD True
treeViewColumnSetClickable cMD True
treeViewColumnSetSortColumnId cMD 2
cellLayoutPackStart cMD renderTxt True
_ <- treeViewAppendColumn treeView cMD
cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
cP <- treeViewColumnNew
treeViewColumnSetTitle cP ("Permission" :: String)
treeViewColumnSetResizable cP True
treeViewColumnSetClickable cP True
treeViewColumnSetSortColumnId cP 3
cellLayoutPackStart cP renderTxt True
_ <- treeViewAppendColumn treeView cP
cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
return $ FMTreeView treeView
refreshView :: MyGUI
-> MyView
-> Maybe (Path Abs)
-> IO ()
refreshView mygui myview mfp =
case mfp of
Just fp -> do
canopen <- canOpenDirectory fp
if canopen
then refreshView' mygui myview =<< readFile getFileInfo fp
else refreshView mygui myview =<< getAlternativeDir
Nothing -> refreshView mygui myview =<< getAlternativeDir
where
getAlternativeDir = do
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
Item)
case ecd of
Right dir -> return (Just $ path dir)
Left _ -> return (P.parseAbs $ BS.singleton pathSeparator)
refreshView' :: MyGUI
-> MyView
-> Item
-> IO ()
refreshView' mygui myview SymLink { sdest = d@Dir{} } =
refreshView' mygui myview d
refreshView' mygui myview item@Dir{} = do
newRawModel <- fileListStore item myview
writeTVarIO (rawModel myview) newRawModel
view' <- readTVarIO $ view myview
_ <- tryTakeMVar (cwd myview)
putMVar (cwd myview) item
tps <- getSelectedTreePaths mygui myview
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
constructView mygui myview
page <- notebookGetCurrentPage (notebook mygui)
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
notebookSetTabLabelText (notebook mygui) child
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
case view' of
FMTreeView treeView -> do
tvs <- treeViewGetSelection treeView
ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return ()
refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
refreshView' _ _ _ = return ()
constructView :: MyGUI
-> MyView
-> IO ()
constructView mygui myview = do
settings' <- readTVarIO $ settings mygui
iT <- iconThemeGetDefault
folderPix <- getIcon IFolder iT (iconSize settings')
folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
filePix <- getIcon IFile iT (iconSize settings')
fileSymPix <- getSymlinkIcon IFile iT (iconSize settings')
errorPix <- getIcon IError iT (iconSize settings')
let dirtreePix Dir{} = folderPix
dirtreePix FileLike{} = filePix
dirtreePix DirSym{} = folderSymPix
dirtreePix FileLikeSym{} = fileSymPix
dirtreePix Failed{} = errorPix
dirtreePix BrokenSymlink{} = errorPix
dirtreePix _ = errorPix
view' <- readTVarIO $ view myview
cdirp <- path <$> getCurrentDir myview
entrySetText (urlBar myview) (P.fromAbs cdirp)
rawModel' <- readTVarIO $ rawModel myview
filteredModel' <- treeModelFilterNew rawModel' []
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
if hidden
then return True
else return . not . hiddenFile . P.fromRel $ item
sortedModel' <- treeModelSortNewWithModel filteredModel'
writeTVarIO (sortedModel myview) sortedModel'
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
item1 <- treeModelGetRow rawModel' cIter1
item2 <- treeModelGetRow rawModel' cIter2
return $ compare item1 item2
treeSortableSetSortColumnId sortedModel' 1 SortAscending
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
dirtreePix
treeModelSetColumn rawModel' (makeColumnIdString 1)
(P.toFilePath . fromJust . P.basename . path)
treeModelSetColumn rawModel' (makeColumnIdString 2)
packModTime
treeModelSetColumn rawModel' (makeColumnIdString 3)
packPermissions
case view' of
FMTreeView treeView -> do
treeViewSetModel treeView sortedModel'
treeViewSetRubberBanding treeView True
FMIconView iconView -> do
iconViewSetModel iconView (Just sortedModel')
iconViewSetPixbufColumn iconView
(makeColumnIdPixbuf 0 :: ColumnId item Pixbuf)
iconViewSetTextColumn iconView
(makeColumnIdString 1 :: ColumnId item String)
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
newi <- initINotify
_ <- addWatch
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
(P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
putMVar (inotify myview) newi
return ()