hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

GTK: implement fileinfo dialog wrt #32

Browse Source
This commit is contained in:
Julian Ospald 2016-04-19 21:05:29 +02:00
parent a7ba20ae00
commit a61b409486
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
6 changed files with 298 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

166
data/Gtk/builder.xml
View File

@ -2,6 +2,163 @@
<!-- Generated with glade 3.18.3 --> <!-- Generated with glade 3.18.3 -->
<interface> <interface>
<requires lib="gtk+" version="3.16"/> <requires lib="gtk+" version="3.16"/>
<object class="GtkGrid" id="fpropGrid">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="row_spacing">2</property>
<property name="column_spacing">2</property>
<property name="row_homogeneous">True</property>
<child>
<object class="GtkLabel" id="label1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="label" translatable="yes">File Name:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">0</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropFnEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">0</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="label" translatable="yes">Location:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">1</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="label" translatable="yes">Total Size:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">2</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label4">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="label" translatable="yes">Modified:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">3</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label5">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="label" translatable="yes">Accessed:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">4</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropLocEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">1</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropTsEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">2</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropModEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">3</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropAcEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">4</property>
</packing>
</child>
</object>
<object class="GtkImage" id="image1"> <object class="GtkImage" id="image1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
@ -458,5 +615,14 @@
<property name="use_stock">True</property> <property name="use_stock">True</property>
</object> </object>
</child> </child>
<child>
<object class="GtkImageMenuItem" id="rcFileProperty">
<property name="label">gtk-properties</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object> </object>
</interface> </interface>

14
src/HSFM/FileSystem/FileType.hs
View File

@ -563,9 +563,17 @@ getFreeVar _ = Nothing
-- |Pack the modification time into a string. -- |Pack the modification time into a string.
packModTime :: File FileInfo packModTime :: File FileInfo
-> String -> String
packModTime = packModTime = fromFreeVar $ epochToString . modificationTime
fromFreeVar
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
-- |Pack the modification time into a string.
packAccessTime :: File FileInfo
-> String
packAccessTime = fromFreeVar $ epochToString . accessTime
epochToString :: EpochTime -> String
epochToString = show . posixSecondsToUTCTime . realToFrac
-- |Pack the permissions into a string, similar to what "ls -l" does. -- |Pack the permissions into a string, similar to what "ls -l" does.

49
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@ -90,7 +90,6 @@ setCallbacks mygui myview = do
\_ -> withItems mygui myview moveInit \_ -> withItems mygui myview moveInit
_ <- treeView `on` dragDrop $ _ <- treeView `on` dragDrop $
\dc p ts -> do \dc p ts -> do
atom <- atomNew ("HSFM" :: String)
p' <- treeViewConvertWidgetToTreeCoords treeView p p' <- treeViewConvertWidgetToTreeCoords treeView p
mpath <- treeViewGetPathAtPos treeView p' mpath <- treeViewGetPathAtPos treeView p'
case mpath of case mpath of
@ -98,6 +97,7 @@ setCallbacks mygui myview = do
dragFinish dc False False ts dragFinish dc False False ts
return False return False
Just _ -> do Just _ -> do
atom <- atomNew ("HSFM" :: String)
dragGetData treeView dc atom ts dragGetData treeView dc atom ts
return True return True
_ <- treeView `on` dragDataReceived $ _ <- treeView `on` dragDataReceived $
@ -125,34 +125,35 @@ setCallbacks mygui myview = do
where where
menubarCallbacks = do menubarCallbacks = do
-- menubar-file -- menubar-file
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit _ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
_ <- menubarFileOpen mygui `on` menuItemActivated $ mainQuit
_ <- (menubarFileOpen . menubar) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview open liftIO $ withItems mygui myview open
_ <- menubarFileExecute mygui `on` menuItemActivated $ _ <- (menubarFileExecute . menubar) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview execute liftIO $ withItems mygui myview execute
_ <- menubarFileNew mygui `on` menuItemActivated $ _ <- (menubarFileNew . menubar) mygui `on` menuItemActivated $
liftIO $ newFile mygui myview liftIO $ newFile mygui myview
-- menubar-edit -- menubar-edit
_ <- menubarEditCut mygui `on` menuItemActivated $ _ <- (menubarEditCut . menubar) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit liftIO $ withItems mygui myview moveInit
_ <- menubarEditCopy mygui `on` menuItemActivated $ _ <- (menubarEditCopy . menubar) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit liftIO $ withItems mygui myview copyInit
_ <- menubarEditRename mygui `on` menuItemActivated $ _ <- (menubarEditRename . menubar) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview renameF liftIO $ withItems mygui myview renameF
_ <- menubarEditPaste mygui `on` menuItemActivated $ _ <- (menubarEditPaste . menubar) mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview Nothing liftIO $ operationFinal mygui myview Nothing
_ <- menubarEditDelete mygui `on` menuItemActivated $ _ <- (menubarEditDelete . menubar) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview del liftIO $ withItems mygui myview del
-- mewnubar-view -- mewnubar-view
_ <- menubarViewIcon mygui `on` menuItemActivated $ _ <- (menubarViewIcon . menubar) mygui `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView liftIO $ switchView mygui myview createIconView
_ <- menubarViewTree mygui `on` menuItemActivated $ _ <- (menubarViewTree . menubar) mygui `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView liftIO $ switchView mygui myview createTreeView
-- menubar-help -- menubar-help
_ <- menubarHelpAbout mygui `on` menuItemActivated $ _ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
liftIO showAboutDialog liftIO showAboutDialog
return () return ()
commonGuiEvents fmv = do commonGuiEvents fmv = do
@ -214,7 +215,7 @@ setCallbacks mygui myview = do
t <- eventTime t <- eventTime
case eb of case eb of
RightButton -> do RightButton -> do
_ <- liftIO $ menuPopup (rcMenu mygui) _ <- liftIO $ menuPopup (rcMenu . rcmenu $ mygui)
$ Just (RightButton, t) $ Just (RightButton, t)
-- this is just to not screw with current selection -- this is just to not screw with current selection
-- on right-click -- on right-click
@ -232,23 +233,25 @@ setCallbacks mygui myview = do
Nothing -> return False Nothing -> return False
-- not right-click, so pass on the signal -- not right-click, so pass on the signal
_ -> return False _ -> return False
_ <- rcFileOpen mygui `on` menuItemActivated $ _ <- (rcFileOpen . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview open liftIO $ withItems mygui myview open
_ <- rcFileExecute mygui `on` menuItemActivated $ _ <- (rcFileExecute . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview execute liftIO $ withItems mygui myview execute
_ <- rcFileNewRegFile mygui `on` menuItemActivated $ _ <- (rcFileNewRegFile . rcmenu) mygui `on` menuItemActivated $
liftIO $ newFile mygui myview liftIO $ newFile mygui myview
_ <- rcFileNewDir mygui `on` menuItemActivated $ _ <- (rcFileNewDir . rcmenu) mygui `on` menuItemActivated $
liftIO $ newDir mygui myview liftIO $ newDir mygui myview
_ <- rcFileCopy mygui `on` menuItemActivated $ _ <- (rcFileCopy . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit liftIO $ withItems mygui myview copyInit
_ <- rcFileRename mygui `on` menuItemActivated $ _ <- (rcFileRename . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview renameF liftIO $ withItems mygui myview renameF
_ <- rcFilePaste mygui `on` menuItemActivated $ _ <- (rcFilePaste . rcmenu) mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview Nothing liftIO $ operationFinal mygui myview Nothing
_ <- rcFileDelete mygui `on` menuItemActivated $ _ <- (rcFileDelete . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview del liftIO $ withItems mygui myview del
_ <- rcFileCut mygui `on` menuItemActivated $ _ <- (rcFileProperty . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview showFilePropertyDialog
_ <- (rcFileCut . rcmenu) mygui `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit liftIO $ withItems mygui myview moveInit
return () return ()
getPathAtPos fmv (x, y) = getPathAtPos fmv (x, y) =

47
src/HSFM/GUI/Gtk/Data.hs
View File

@ -30,6 +30,7 @@ import Control.Concurrent.STM
TVar TVar
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import Graphics.UI.Gtk hiding (MenuBar)
import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import System.INotify.ByteString import System.INotify.ByteString
@ -50,8 +51,27 @@ import System.INotify.ByteString
-- runtime. -- runtime.
data MyGUI = MkMyGUI { data MyGUI = MkMyGUI {
-- |main Window -- |main Window
rootWin :: Window rootWin :: Window
, menubarFileQuit :: ImageMenuItem
-- widgets on the main window
, upViewB :: Button
, homeViewB :: Button
, refreshViewB :: Button
, urlBar :: Entry
, statusBar :: Statusbar
, clearStatusBar :: Button
, settings :: TVar FMSettings
, scroll :: ScrolledWindow
, fprop :: FilePropertyGrid
-- sub-widgets
, menubar :: MenuBar
, rcmenu :: RightClickMenu
}
data MenuBar = MkMenuBar {
menubarFileQuit :: ImageMenuItem
, menubarFileOpen :: ImageMenuItem , menubarFileOpen :: ImageMenuItem
, menubarFileExecute :: ImageMenuItem , menubarFileExecute :: ImageMenuItem
, menubarFileNew :: ImageMenuItem , menubarFileNew :: ImageMenuItem
@ -63,7 +83,10 @@ data MyGUI = MkMyGUI {
, menubarViewTree :: ImageMenuItem , menubarViewTree :: ImageMenuItem
, menubarViewIcon :: ImageMenuItem , menubarViewIcon :: ImageMenuItem
, menubarHelpAbout :: ImageMenuItem , menubarHelpAbout :: ImageMenuItem
, rcMenu :: Menu }
data RightClickMenu = MkRightClickMenu {
rcMenu :: Menu
, rcFileOpen :: ImageMenuItem , rcFileOpen :: ImageMenuItem
, rcFileExecute :: ImageMenuItem , rcFileExecute :: ImageMenuItem
, rcFileNewRegFile :: ImageMenuItem , rcFileNewRegFile :: ImageMenuItem
@ -73,14 +96,16 @@ data MyGUI = MkMyGUI {
, rcFileRename :: ImageMenuItem , rcFileRename :: ImageMenuItem
, rcFilePaste :: ImageMenuItem , rcFilePaste :: ImageMenuItem
, rcFileDelete :: ImageMenuItem , rcFileDelete :: ImageMenuItem
, upViewB :: Button , rcFileProperty :: ImageMenuItem
, homeViewB :: Button }
, refreshViewB :: Button
, urlBar :: Entry data FilePropertyGrid = MkFilePropertyGrid {
, statusBar :: Statusbar fpropGrid :: Grid
, clearStatusBar :: Button , fpropFnEntry :: Entry
, settings :: TVar FMSettings , fpropLocEntry :: Entry
, scroll :: ScrolledWindow , fpropTsEntry :: Entry
, fpropModEntry :: Entry
, fpropAcEntry :: Entry
} }

42
src/HSFM/GUI/Gtk/Dialogs.hs
View File

@ -36,6 +36,7 @@ import Control.Monad
, when , when
, void , void
) )
import qualified Data.ByteString as BS
import Data.Version import Data.Version
( (
showVersion showVersion
@ -62,6 +63,9 @@ import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType
import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Errors import HSFM.GUI.Gtk.Errors
import Paths_hsfm import Paths_hsfm
( (
@ -180,7 +184,7 @@ withCopyModeDialog fa =
showAboutDialog :: IO () showAboutDialog :: IO ()
showAboutDialog = do showAboutDialog = do
ad <- aboutDialogNew ad <- aboutDialogNew
lstr <- readFile =<< getDataFileName "LICENSE" lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png" hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
pdesc <- fmap packageDescription pdesc <- fmap packageDescription
(readPackageDescription silent (readPackageDescription silent
@ -244,3 +248,39 @@ textInputDialog title = do
_ -> throw UnknownDialogButton _ -> throw UnknownDialogButton
widgetDestroy chooserDialog widgetDestroy chooserDialog
return ret return ret
showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
showFilePropertyDialog [item] mygui _ = do
dialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageInfo
ButtonsNone
"File Properties"
let fprop' = fprop mygui
grid = fpropGrid fprop'
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
$ P.basename . path $ item)
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
entrySetText (fpropModEntry fprop') (packModTime item)
entrySetText (fpropAcEntry fprop') (packAccessTime item)
cbox <- dialogGetActionArea dialog
_ <- dialogAddButton dialog "Ok" (ResponseUser 0)
_ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) grid PackNatural 5
widgetShowAll dialog
_ <- dialogRun dialog
-- make sure our grid does not get destroyed
containerRemove (castToBox cbox) grid
widgetDestroy dialog
return ()
showFilePropertyDialog _ _ _ = return ()

18
src/HSFM/GUI/Gtk/MyGUI.hs
View File

@ -16,6 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.MyGUI where module HSFM.GUI.Gtk.MyGUI where
@ -101,6 +102,8 @@ createMyGUI = do
"rcFilePaste" "rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete" "rcFileDelete"
rcFileProperty <- builderGetObject builder castToImageMenuItem
"rcFileProperty"
upViewB <- builderGetObject builder castToButton upViewB <- builderGetObject builder castToButton
"upViewB" "upViewB"
homeViewB <- builderGetObject builder castToButton homeViewB <- builderGetObject builder castToButton
@ -111,8 +114,23 @@ createMyGUI = do
"menubarViewTree" "menubarViewTree"
menubarViewIcon <- builderGetObject builder castToImageMenuItem menubarViewIcon <- builderGetObject builder castToImageMenuItem
"menubarViewIcon" "menubarViewIcon"
fpropGrid <- builderGetObject builder castToGrid
"fpropGrid"
fpropFnEntry <- builderGetObject builder castToEntry
"fpropFnEntry"
fpropLocEntry <- builderGetObject builder castToEntry
"fpropLocEntry"
fpropTsEntry <- builderGetObject builder castToEntry
"fpropTsEntry"
fpropModEntry <- builderGetObject builder castToEntry
"fpropModEntry"
fpropAcEntry <- builderGetObject builder castToEntry
"fpropAcEntry"
-- construct the gui object -- construct the gui object
let menubar = MkMenuBar {..}
let rcmenu = MkRightClickMenu {..}
let fprop = MkFilePropertyGrid {..}
let mygui = MkMyGUI {..} let mygui = MkMyGUI {..}
-- sets the default icon -- sets the default icon