{-- HSFM, a filemanager written in Haskell. Copyright (C) 2016 Julian Ospald This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License version 2 as published by the Free Software Foundation. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. --} {-# LANGUAGE RecordWildCards #-} module HSFM.GUI.Gtk.MyView where import Control.Concurrent.MVar ( newEmptyMVar , putMVar , tryTakeMVar ) import Control.Concurrent.STM ( newTVarIO , readTVarIO ) import Control.Monad ( unless , void , when ) import Control.Monad.IO.Class ( liftIO ) import Data.Foldable ( for_ ) import Data.Maybe ( catMaybes , fromJust ) import Data.String ( fromString ) import Graphics.UI.Gtk import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks) 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.History import HSFM.Utils.IO import Paths_hsfm ( getDataFileName ) import Prelude hiding(readFile) import System.INotify ( addWatch , initINotify , killINotify , EventVariety(..) ) import System.IO.Error ( catchIOError , ioError , isUserError ) import System.Posix.FilePath ( hiddenFile ) -- |Creates a new tab with its own view and refreshes the view. newTab :: MyGUI -> Notebook -> IO FMView -> Item -> Int -> IO MyView newTab mygui nb iofmv item pos = do -- create eventbox with label label <- labelNewWithMnemonic (maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item) ebox <- eventBoxNew eventBoxSetVisibleWindow ebox False containerAdd ebox label widgetShowAll label myview <- createMyView mygui nb iofmv _ <- notebookInsertPageMenu (notebook myview) (viewBox myview) ebox ebox pos -- set initial history let historySize = 5 putMVar (history myview) (BrowsingHistory [] (path item) [] historySize) notebookSetTabReorderable (notebook myview) (viewBox myview) True catchIOError (refreshView mygui myview item) $ \e -> do file <- pathToFile getFileInfo . fromJust . P.parseAbs . fromString $ "/" refreshView mygui myview file labelSetText label (fromString "/" :: String) unless (isUserError e) (ioError e) -- close callback _ <- ebox `on` buttonPressEvent $ do eb <- eventButton case eb of MiddleButton -> liftIO $ do n <- notebookGetNPages (notebook myview) when (n > 1) $ void $ destroyView myview return True _ -> return False return myview -- |Constructs the initial MyView object with a few dummy models. -- It also initializes the callbacks. createMyView :: MyGUI -> Notebook -> IO FMView -> IO MyView createMyView mygui nb iofmv = do inotify <- newEmptyMVar history <- newEmptyMVar builder <- builderNew builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" -- create dummy models, so we don't have to use MVar 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" backViewB <- builderGetObject builder castToButton "backViewB" upViewB <- builderGetObject builder castToButton "upViewB" forwardViewB <- builderGetObject builder castToButton "forwardViewB" homeViewB <- builderGetObject builder castToButton "homeViewB" refreshViewB <- builderGetObject builder castToButton "refreshViewB" scroll <- builderGetObject builder castToScrolledWindow "mainScroll" viewBox <- builderGetObject builder castToBox "viewBox" let notebook = nb let myview = MkMyView {..} -- set the bindings setViewCallbacks mygui myview -- add the treeview to the scroll container let oview = fmViewToContainer view' containerAdd scroll oview widgetShowAll viewBox return myview -- |Switch the existing view in `MyView` with the one that the -- io action returns. switchView :: MyGUI -> MyView -> IO FMView -> IO () switchView mygui myview iofmv = do cwd <- getCurrentDir myview let nb = notebook myview oldpage <- destroyView myview -- create new view and tab page where the previous one was nview <- newTab mygui nb iofmv cwd oldpage page <- fromJust <$> notebookPageNum nb (viewBox nview) notebookSetCurrentPage nb page refreshView mygui nview cwd -- |Destroys the given view by disconnecting the watcher -- and destroying the active FMView container. -- -- Everything that needs to be done in order to forget about a -- view needs to be done here. -- -- Returns the page in the tab list this view corresponds to. destroyView :: MyView -> IO Int destroyView myview = do -- disconnect watcher mi <- tryTakeMVar (inotify myview) for_ mi $ \i -> killINotify i page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview) -- destroy old view and tab page view' <- readTVarIO $ view myview widgetDestroy (fmViewToContainer view') notebookRemovePage (notebook myview) page return page -- |Createss an IconView. createIconView :: IO FMView createIconView = do iconv <- iconViewNew iconViewSetSelectionMode iconv SelectionMultiple iconViewSetColumns iconv (-1) iconViewSetSpacing iconv 2 iconViewSetMargin iconv 0 {- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -} {- set iconv [ iconViewOrientation := OrientationHorizontal ] -} return $ FMIconView iconv -- |Creates a TreeView. createTreeView :: IO FMView createTreeView = do -- create the final view treeView <- treeViewNew -- set selection mode tvs <- treeViewGetSelection treeView treeSelectionSetMode tvs SelectionMultiple -- set drag and drop tl <- targetListNew atom <- atomNew ("HSFM" :: String) targetListAdd tl atom [TargetSameApp] 0 treeViewEnableModelDragDest treeView tl [ActionCopy] treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy] -- 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" :: 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 -- date column 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 -- permissions column 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 -- |Refreshes the View based on the given directory. -- -- Throws: -- -- - `userError` on inappropriate type refreshView :: MyGUI -> MyView -> Item -> IO () refreshView mygui myview SymLink { sdest = Just 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 -- get selected items tps <- getSelectedTreePaths mygui myview trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps constructView mygui myview -- reselect selected items -- TODO: not implemented for icon view yet case view' of FMTreeView treeView -> do tvs <- treeViewGetSelection treeView ntps <- mapM treeRowReferenceGetPath trs mapM_ (treeSelectionSelectPath tvs) ntps _ -> return () refreshView _ _ _ = ioError $ userError "Inappropriate type!" -- |Constructs the visible View with the current underlying mutable models, -- which are retrieved from 'MyGUI'. -- -- This sort of merges the components mygui and myview and fires up -- the actual models. constructView :: MyGUI -> MyView -> IO () constructView mygui myview = do settings' <- readTVarIO $ settings mygui -- pix stuff 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 BrokenSymlink{} = errorPix dirtreePix _ = errorPix view' <- readTVarIO $ view myview cdir <- getCurrentDir myview let cdirp = path cdir -- update urlBar entrySetText (urlBar myview) (P.fromAbs cdirp) rawModel' <- readTVarIO $ rawModel myview -- filtering 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 -- sorting 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 -- set values 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 -- update model of view case view' of FMTreeView treeView -> do treeViewSetModel treeView (Just 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) -- add watcher 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 cdir) putMVar (inotify myview) newi return ()