module Manatee.Extension.FileManager.DiredView where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Data.ByteString.UTF8
import Data.List
import Data.Map (Map)
import Data.Text.Lazy (Text)
import Data.Typeable
import Graphics.UI.Gtk hiding (Statusbar, statusbarNew, get)
import Graphics.UI.Gtk.Gdk.SerializedEvent
import Manatee.Core.DBus
import Manatee.Core.FileOpenRule
import Manatee.Core.PageView
import Manatee.Core.Types
import Manatee.Extension.FileManager.DiredBuffer
import Manatee.Toolkit.General.Basic
import Manatee.Toolkit.General.FilePath
import Manatee.Toolkit.General.Functor
import Manatee.Toolkit.General.Map
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.Gio.Gio
import Manatee.Toolkit.Gtk.Concurrent
import Manatee.Toolkit.Gtk.Gtk
import Manatee.Toolkit.Gtk.ModelView
import Manatee.Toolkit.Gtk.ScrolledWindow
import System.FilePath
import qualified Data.Map as M
data DiredView =
DiredView {diredViewPlugId :: TVar PagePlugId
,diredViewScrolledWindow :: ScrolledWindow
,diredViewBuffer :: DiredBuffer
,diredViewTreeView :: TreeView
,diredViewListStore :: ListStore DiredFileInfo
,diredViewSortModel :: TypedTreeModelSort DiredFileInfo
,diredViewBroadcastChannel :: ViewChannel DiredBufferSignal
} deriving Typeable
instance PageBuffer DiredBuffer where
pageBufferGetName = readTVarIO . diredBufferCurrentDirectory
pageBufferSetName a = writeTVarIO (diredBufferCurrentDirectory a)
pageBufferClient = diredBufferClient
pageBufferCreateView a pId = PageViewWrap <$> diredViewNew a pId
pageBufferMode = diredBufferMode
instance PageView DiredView where
pageViewBuffer = PageBufferWrap . diredViewBuffer
pageViewPlugId = diredViewPlugId
pageViewFocus = treeViewFocus . diredViewTreeView
pageViewScrolledWindow = diredViewScrolledWindow
pageViewHandleKeyAction = diredViewHandleKeyAction
pageViewScrollToTop = diredViewScrollToTop
pageViewScrollToBottom = diredViewScrollToBottom
pageViewScrollVerticalPage = diredViewScrollVerticalPage
pageViewScrollVerticalStep = diredViewScrollVerticalStep
diredViewNew :: DiredBuffer -> PagePlugId -> IO DiredView
diredViewNew buffer plugId = do
pId <- newTVarIO plugId
scrolledWindow <- scrolledWindowNew_
treeView <- treeViewNew
treeViewSetEnableTreeLines treeView True
scrolledWindow `containerAdd` treeView
listStore <- listStoreNew []
sortModel <- treeModelSortNewWithModel listStore
channel <- createViewChannel (diredBufferBroadcastChannel buffer) treeView
let diredView = DiredView pId scrolledWindow buffer treeView listStore sortModel channel
diredViewListenChannel diredView
diredViewDraw diredView
return diredView
diredViewListenChannel :: DiredView -> IO ()
diredViewListenChannel view =
listenViewChannel (diredViewBroadcastChannel view) $ \ signal ->
case signal of
UpdateView directory -> do
diredViewDraw view
case directory of
Just dir -> do
list <- listStoreToList (diredViewListStore view)
findIndex (\x -> fst (dfiNameDescrible x) == dir) list ?>= \ i -> do
path <- treeModelSortConvertChildPathToPath (diredViewSortModel view) [i]
treeViewSetCursor (diredViewTreeView view) path Nothing
Nothing ->
treeViewFocusFirstToplevelNode (diredViewTreeView view)
_ -> return ()
diredViewEntryDirectory :: DiredView -> FilePath -> Maybe String -> IO ()
diredViewEntryDirectory view path currentDir = do
let channel = viewChannel $ diredViewBroadcastChannel view
writeTChanIO channel (UpdateBuffer path)
diredBufferLoad (diredViewBuffer view) path
writeTChanIO channel (UpdateView currentDir)
diredViewDraw :: DiredView -> IO ()
diredViewDraw view = do
let buffer = diredViewBuffer view
fileInfos <- readTVarIO $ diredBufferFileInfos buffer
database <- readTVarIO $ diredBufferIconPixbufDatabase buffer
let treeView = diredViewTreeView view
store = diredViewListStore view
model = diredViewSortModel view
listStoreClear store
forM_ fileInfos (listStoreAppend store)
treeViewSetModel treeView model
treeViewRemoveColumns treeView
diredViewAddIconColumn treeView store database
forM_ (diredBufferFileInfoOptions buffer) (diredViewAddColumn treeView store model)
sortStatus <- readTVarIO $ diredBufferSortStatus buffer
diredViewSortInternal view sortStatus
return ()
diredViewAddIconColumn :: TreeViewClass tv => tv -> ListStore DiredFileInfo -> FileIconPixbufDatabase -> IO ()
diredViewAddIconColumn treeView store database = do
tvc <- treeViewColumnNew
set tvc [treeViewColumnTitle := ""]
treeViewAppendColumn treeView tvc
icon <- cellRendererPixbufNew
treeViewColumnPackStart tvc icon True
cellLayoutSetAttributes tvc icon store $ \DiredFileInfo {dfiMimeDescrible = (fMime, _)} ->
[cellPixbuf :=> do
let (_, pixbuf) = maybeError (findMinMatch database (\ mime _ -> mime == fMime))
("diredViewAddIconColumn: can't find pixbuf match in database : " ++ show fMime)
return pixbuf]
diredViewAddColumn :: (DiredFileInfoClass t,
TreeViewClass self1,
TreeModelClass self,
TreeModelSortClass self,
TypedTreeModelClass model,
TreeSortableClass self) =>
self1
-> model DiredFileInfo
-> self
-> (t, SortColumnId)
-> IO ()
diredViewAddColumn treeView model sortModel option@(info,sortId) = do
diredViewSetSortFunc model sortModel option
let name = getColumnTitle info
tvc <- treeViewAddColumnWithTitle treeView name sortId
cell <- cellRendererTextNew
treeViewColumnPackStart tvc cell True
diredViewSetCellText tvc cell model sortModel info
diredViewSetSortFunc :: (TreeSortableClass self,
TypedTreeModelClass model,
DiredFileInfoClass a) =>
model DiredFileInfo
-> self
-> (a, SortColumnId)
-> IO ()
diredViewSetSortFunc model sortModel (info, sortId) =
treeSortableSetSortFunc sortModel sortId $ \iter1 iter2 -> do
row1 <- treeModelGetRow model iter1
row2 <- treeModelGetRow model iter2
compareRow info row1 row2
diredViewSetCellText :: (CellLayoutClass self,
CellRendererTextClass cell,
TreeModelClass model,
TreeModelSortClass model,
TypedTreeModelClass model1,
DiredFileInfoClass a) =>
self
-> cell
-> model1 DiredFileInfo
-> model
-> a
-> IO ()
diredViewSetCellText tvc cell model sortModel info =
cellLayoutSetAttributeFunc tvc cell sortModel $ \iter -> do
row <- treeModelSortGetRow model sortModel iter
set cell [cellText := getCellText info row
,cellXAlign := getCellXAlign info]
diredViewNextNode :: DiredView -> IO ()
diredViewNextNode = treeViewFocusNextToplevelNode . diredViewTreeView
diredViewPrevNode :: DiredView -> IO ()
diredViewPrevNode = treeViewFocusPrevToplevelNode . diredViewTreeView
diredViewEntryNode :: Bool -> DiredView -> IO ()
diredViewEntryNode newTab view =
treeViewGetSelectedValue (diredViewTreeView view)
(diredViewSortModel view)
(diredViewListStore view)
>?>= \ fileInfo -> do
let fileName = (fst . dfiNameDescrible) fileInfo
fileType = (fst . dfiMimeDescrible) fileInfo
filePath <- liftM (</> fileName) $ pageBufferGetName (diredViewBuffer view)
let displayPath = filepathGetDisplayName (fromString filePath)
if directoryDoesExist (fromString filePath)
then if newTab
then mkDaemonSignal (pageViewClient view) NewTab (NewTabArgs "PageFileManager" filePath)
else diredViewEntryDirectory view filePath Nothing
else if fileDoesExist (fromString filePath)
then do
openRule <- fileOpenRule filePath fileType
if null openRule
then pageViewUpdateOutputStatus
view
("Don't know how to open file : " ++ displayPath)
Nothing
else do
let rule = snd $ head openRule
rule (pageViewClient view)
else pageViewUpdateOutputStatus
view
("diredViewEntryNode: " ++ displayPath ++ " is not valid filepath.")
Nothing
diredViewUpperDirectory :: Bool -> DiredView -> IO ()
diredViewUpperDirectory newTab view = do
let buffer = diredViewBuffer view
dir <- pageBufferGetName buffer
let upperDir = getUpperDirectory dir
unless (dir == upperDir) $
if newTab
then mkDaemonSignal (pageViewClient view) NewTab (NewTabArgs "PageFileManager" upperDir)
else diredViewEntryDirectory view upperDir (Just (takeFileName $ dropTrailingPathSeparator dir))
diredViewSortByName :: DiredView -> IO ()
diredViewSortByName view = diredViewSort view FIName
diredViewSortBySize :: DiredView -> IO ()
diredViewSortBySize view = diredViewSort view FISize
diredViewSortByMime :: DiredView -> IO ()
diredViewSortByMime view = diredViewSort view FIMime
diredViewSortByMTime :: DiredView -> IO ()
diredViewSortByMTime view = diredViewSort view FIMTime
diredViewSort :: DiredView -> FileInfoOption -> IO ()
diredViewSort view option = do
let model = diredViewSortModel view
buffer = diredViewBuffer view
options = diredBufferFileInfoOptions buffer
(curSortType, _, curSortColumnId) <- treeSortableGetSortColumnId model
lookup option options ?>= \id -> do
treeSortableSetSortColumnId model id $
if id == curSortColumnId
then
case curSortType of
SortAscending -> SortDescending
SortDescending -> SortAscending
else SortAscending
(newSortType, _, _) <- treeSortableGetSortColumnId model
writeTVarIO (diredBufferSortStatus $ diredViewBuffer view) (option, newSortType)
treeViewFocus (diredViewTreeView view)
diredViewSortInternal :: DiredView -> (FileInfoOption, SortType) -> IO ()
diredViewSortInternal view (option, sortType) = do
let options = diredBufferFileInfoOptions $ diredViewBuffer view
lookup option options ?>= \x ->
treeSortableSetSortColumnId (diredViewSortModel view) x sortType
diredViewKeymap :: Map Text (DiredView -> IO ())
diredViewKeymap =
M.fromList
[("j", diredViewNextNode)
,("k", diredViewPrevNode)
,("Down", diredViewNextNode)
,("Up", diredViewPrevNode)
,("J", diredViewScrollToBottom)
,("K", diredViewScrollToTop)
,(" ", diredViewScrollVerticalPage True)
,("b", diredViewScrollVerticalPage False)
,("PageDown", diredViewScrollVerticalPage True)
,("PageUp", diredViewScrollVerticalPage False)
,("n", diredViewSortByName)
,("x", diredViewSortByMime)
,("s", diredViewSortBySize)
,("t", diredViewSortByMTime)
,("'", diredViewUpperDirectory False)
,("\"", diredViewUpperDirectory True)
,("m", diredViewEntryNode False)
,("Return", diredViewEntryNode False)
,("M", diredViewEntryNode True)
]
diredViewScrollToTop :: DiredView -> IO ()
diredViewScrollToTop =
treeViewFocusFirstToplevelNode . diredViewTreeView
diredViewScrollToBottom :: DiredView -> IO ()
diredViewScrollToBottom =
treeViewFocusLastToplevelNode . diredViewTreeView
diredViewScrollVerticalPage :: Bool -> DiredView -> IO ()
diredViewScrollVerticalPage isDown a = do
let sw = diredViewScrolledWindow a
tv = diredViewTreeView a
pageInc <- (<=<) adjustmentGetPageIncrement scrolledWindowGetVAdjustment sw
treeViewScrollVertical tv sw (if isDown then pageInc else ( pageInc))
diredViewScrollVerticalStep :: Bool -> DiredView -> IO ()
diredViewScrollVerticalStep isDown a = do
let sw = diredViewScrolledWindow a
tv = diredViewTreeView a
stepInc <- (<<<=) integralToDouble treeViewGetSelectedCellHeight tv
treeViewScrollVertical tv sw (if isDown then stepInc else ( stepInc))
diredViewHandleKeyAction :: DiredView -> Text -> SerializedEvent -> IO ()
diredViewHandleKeyAction view keystoke sEvent =
case M.lookup keystoke diredViewKeymap of
Just action -> action view
Nothing -> widgetPropagateEvent (diredViewTreeView view) sEvent