GTK: implement fileinfo dialog wrt #32

2016-04-19 21:05:29 +02:00 · 2016-04-19 21:05:29 +02:00 · a61b409486
commit a61b409486
parent a7ba20ae00
6 changed files with 298 additions and 38 deletions
--- a/data/Gtk/builder.xml
+++ b/data/Gtk/builder.xml
@ -2,6 +2,163 @@
 <!-- Generated with glade 3.18.3 -->
 <interface>
  <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">
    <property name="visible">True</property>
    <property name="can_focus">False</property>
@ -458,5 +615,14 @@
        <property name="use_stock">True</property>
      </object>
    </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>
 </interface>
--- a/src/HSFM/FileSystem/FileType.hs
+++ b/src/HSFM/FileSystem/FileType.hs
@ -563,9 +563,17 @@ getFreeVar _                  = Nothing
 -- |Pack the modification time into a string.
 packModTime :: File FileInfo
            -> String
-packModTime =
-  fromFreeVar
-    $ show . posixSecondsToUTCTime . realToFrac . modificationTime
+packModTime = fromFreeVar $ epochToString . 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.
--- a/src/HSFM/GUI/Gtk/Callbacks.hs
+++ b/src/HSFM/GUI/Gtk/Callbacks.hs
@ -90,7 +90,6 @@ setCallbacks mygui myview = do
        \_ -> withItems mygui myview moveInit
      _ <- treeView `on` dragDrop $
         \dc p ts -> do
-           atom  <- atomNew ("HSFM" :: String)
           p'    <- treeViewConvertWidgetToTreeCoords treeView p
           mpath <- treeViewGetPathAtPos treeView p'
           case mpath of
@ -98,6 +97,7 @@ setCallbacks mygui myview = do
               dragFinish dc False False ts
               return False
             Just _  -> do
+               atom  <- atomNew ("HSFM" :: String)
               dragGetData treeView dc atom ts
               return True
      _ <- treeView `on` dragDataReceived $
@ -125,34 +125,35 @@ setCallbacks mygui myview = do
  where
    menubarCallbacks = do
      -- menubar-file
-      _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
-      _ <- menubarFileOpen mygui `on` menuItemActivated $
+      _ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
+        mainQuit
+      _ <- (menubarFileOpen . menubar) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview open
-      _ <- menubarFileExecute mygui `on` menuItemActivated $
+      _ <- (menubarFileExecute . menubar) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview execute
-      _ <- menubarFileNew mygui `on` menuItemActivated $
+      _ <- (menubarFileNew . menubar) mygui `on` menuItemActivated $
        liftIO $ newFile mygui myview

      -- menubar-edit
-      _ <- menubarEditCut mygui `on` menuItemActivated $
+      _ <- (menubarEditCut . menubar) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview moveInit
-      _ <- menubarEditCopy mygui `on` menuItemActivated $
+      _ <- (menubarEditCopy . menubar) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview copyInit
-      _ <- menubarEditRename mygui `on` menuItemActivated $
+      _ <- (menubarEditRename . menubar) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview renameF
-      _ <- menubarEditPaste mygui `on` menuItemActivated $
+      _ <- (menubarEditPaste . menubar) mygui `on` menuItemActivated $
        liftIO $ operationFinal mygui myview Nothing
-      _ <- menubarEditDelete mygui `on` menuItemActivated $
+      _ <- (menubarEditDelete . menubar) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview del

      -- mewnubar-view
-      _ <- menubarViewIcon mygui `on` menuItemActivated $
+      _ <- (menubarViewIcon . menubar) mygui `on` menuItemActivated $
        liftIO $ switchView mygui myview createIconView
-      _ <- menubarViewTree mygui `on` menuItemActivated $
+      _ <- (menubarViewTree . menubar) mygui `on` menuItemActivated $
        liftIO $ switchView mygui myview createTreeView

      -- menubar-help
-      _ <- menubarHelpAbout mygui `on` menuItemActivated $
+      _ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
        liftIO showAboutDialog
      return ()
    commonGuiEvents fmv = do
@ -214,7 +215,7 @@ setCallbacks mygui myview = do
        t  <- eventTime
        case eb of
          RightButton -> do
-              _ <- liftIO $ menuPopup (rcMenu mygui)
+              _ <- liftIO $ menuPopup (rcMenu . rcmenu $ mygui)
                          $ Just (RightButton, t)
              -- this is just to not screw with current selection
              -- on right-click
@ -232,23 +233,25 @@ setCallbacks mygui myview = do
                Nothing -> return False
          -- not right-click, so pass on the signal
          _ -> return False
-      _ <- rcFileOpen mygui `on` menuItemActivated $
+      _ <- (rcFileOpen . rcmenu) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview open
-      _ <- rcFileExecute mygui `on` menuItemActivated $
+      _ <- (rcFileExecute . rcmenu) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview execute
-      _ <- rcFileNewRegFile mygui `on` menuItemActivated $
+      _ <- (rcFileNewRegFile . rcmenu) mygui `on` menuItemActivated $
        liftIO $ newFile mygui myview
-      _ <- rcFileNewDir mygui `on` menuItemActivated $
+      _ <- (rcFileNewDir . rcmenu) mygui `on` menuItemActivated $
        liftIO $ newDir mygui myview
-      _ <- rcFileCopy mygui `on` menuItemActivated $
+      _ <- (rcFileCopy . rcmenu) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview copyInit
-      _ <- rcFileRename mygui `on` menuItemActivated $
+      _ <- (rcFileRename . rcmenu) mygui `on` menuItemActivated $
        liftIO $ withItems mygui myview renameF
-      _ <- rcFilePaste mygui `on` menuItemActivated $
+      _ <- (rcFilePaste . rcmenu) mygui `on` menuItemActivated $
        liftIO $ operationFinal mygui myview Nothing
-      _ <- rcFileDelete mygui `on` menuItemActivated $
+      _ <- (rcFileDelete . rcmenu) mygui `on` menuItemActivated $
        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
      return ()
    getPathAtPos fmv (x, y) =
--- a/src/HSFM/GUI/Gtk/Data.hs
+++ b/src/HSFM/GUI/Gtk/Data.hs
@ -30,6 +30,7 @@ import Control.Concurrent.STM
    TVar
  )
 import Graphics.UI.Gtk
+import Graphics.UI.Gtk hiding (MenuBar)
 import HSFM.FileSystem.FileOperations
 import HSFM.FileSystem.FileType
 import System.INotify.ByteString
@ -50,8 +51,27 @@ import System.INotify.ByteString
 -- runtime.
 data MyGUI = MkMyGUI {
  -- |main Window
-    rootWin  :: Window
-  , menubarFileQuit :: ImageMenuItem
+    rootWin :: Window
+
+  -- 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
  , menubarFileExecute :: ImageMenuItem
  , menubarFileNew :: ImageMenuItem
@ -63,7 +83,10 @@ data MyGUI = MkMyGUI {
  , menubarViewTree :: ImageMenuItem
  , menubarViewIcon :: ImageMenuItem
  , menubarHelpAbout :: ImageMenuItem
-  , rcMenu :: Menu
+}
+
+data RightClickMenu = MkRightClickMenu {
+    rcMenu :: Menu
  , rcFileOpen :: ImageMenuItem
  , rcFileExecute :: ImageMenuItem
  , rcFileNewRegFile :: ImageMenuItem
@ -73,14 +96,16 @@ data MyGUI = MkMyGUI {
  , rcFileRename :: ImageMenuItem
  , rcFilePaste :: ImageMenuItem
  , rcFileDelete :: ImageMenuItem
-  , upViewB :: Button
-  , homeViewB :: Button
-  , refreshViewB :: Button
-  , urlBar :: Entry
-  , statusBar :: Statusbar
-  , clearStatusBar :: Button
-  , settings :: TVar FMSettings
-  , scroll :: ScrolledWindow
+  , rcFileProperty :: ImageMenuItem
+}
+
+data FilePropertyGrid = MkFilePropertyGrid {
+    fpropGrid :: Grid
+  , fpropFnEntry :: Entry
+  , fpropLocEntry :: Entry
+  , fpropTsEntry :: Entry
+  , fpropModEntry :: Entry
+  , fpropAcEntry :: Entry
 }


--- a/src/HSFM/GUI/Gtk/Dialogs.hs
+++ b/src/HSFM/GUI/Gtk/Dialogs.hs
@ -36,6 +36,7 @@ import Control.Monad
  , when
  , void
  )
+import qualified Data.ByteString as BS
 import Data.Version
  (
    showVersion
@ -62,6 +63,9 @@ import Graphics.UI.Gtk
 import qualified HPath as P
 import HSFM.FileSystem.Errors
 import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import HSFM.GUI.Glib.GlibString()
+import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Errors
 import Paths_hsfm
  (
@ -180,7 +184,7 @@ withCopyModeDialog fa =
 showAboutDialog :: IO ()
 showAboutDialog = do
  ad       <- aboutDialogNew
-  lstr     <- readFile =<< getDataFileName "LICENSE"
+  lstr     <- Prelude.readFile =<< getDataFileName "LICENSE"
  hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
  pdesc    <- fmap packageDescription
                   (readPackageDescription silent
@ -244,3 +248,39 @@ textInputDialog title = do
           _              -> throw  UnknownDialogButton
  widgetDestroy chooserDialog
  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 ()
+
--- a/src/HSFM/GUI/Gtk/MyGUI.hs
+++ b/src/HSFM/GUI/Gtk/MyGUI.hs
@ -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.
 --}

+{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_HADDOCK ignore-exports #-}

 module HSFM.GUI.Gtk.MyGUI where
@ -101,6 +102,8 @@ createMyGUI = do
                       "rcFilePaste"
  rcFileDelete      <- builderGetObject builder castToImageMenuItem
                       "rcFileDelete"
+  rcFileProperty    <- builderGetObject builder castToImageMenuItem
+                       "rcFileProperty"
  upViewB           <- builderGetObject builder castToButton
                       "upViewB"
  homeViewB         <- builderGetObject builder castToButton
@ -111,8 +114,23 @@ createMyGUI = do
                       "menubarViewTree"
  menubarViewIcon   <- builderGetObject builder castToImageMenuItem
                       "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
+  let menubar = MkMenuBar {..}
+  let rcmenu = MkRightClickMenu {..}
+  let fprop = MkFilePropertyGrid {..}
  let mygui  = MkMyGUI {..}

  -- sets the default icon