LIB/GTK: add move menuitem and implement creating new files

2015-12-25 22:51:45 +01:00 · 2015-12-25 22:51:45 +01:00 · 71a2cb90be
commit 71a2cb90be
parent c98db302ba
8 changed files with 153 additions and 4 deletions
--- a/data/Gtk/builder.xml
+++ b/data/Gtk/builder.xml
@ -2,6 +2,11 @@
 <!-- Generated with glade 3.19.0 -->
 <interface>
  <requires lib="gtk+" version="3.16"/>
+  <object class="GtkImage" id="image1">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-edit</property>
+  </object>
  <object class="GtkMenu" id="rcMenu">
    <property name="visible">True</property>
    <property name="can_focus">False</property>
@ -23,6 +28,15 @@
        <property name="use_stock">True</property>
      </object>
    </child>
+    <child>
+      <object class="GtkImageMenuItem" id="rcFileNew">
+        <property name="label">gtk-new</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>
    <child>
      <object class="GtkSeparatorMenuItem" id="separatormenuitem2">
        <property name="visible">True</property>
@ -47,6 +61,15 @@
        <property name="use_stock">True</property>
      </object>
    </child>
+    <child>
+      <object class="GtkImageMenuItem" id="rcFileMove">
+        <property name="label">Move</property>
+        <property name="visible">True</property>
+        <property name="can_focus">False</property>
+        <property name="image">image1</property>
+        <property name="use_stock">False</property>
+      </object>
+    </child>
    <child>
      <object class="GtkImageMenuItem" id="rcFilePaste">
        <property name="label">gtk-paste</property>
@ -66,6 +89,11 @@
      </object>
    </child>
  </object>
+  <object class="GtkImage" id="image2">
+    <property name="visible">True</property>
+    <property name="can_focus">False</property>
+    <property name="stock">gtk-edit</property>
+  </object>
  <object class="GtkApplicationWindow" id="rootWin">
    <property name="can_focus">False</property>
    <child>
@ -105,6 +133,15 @@
                        <property name="use_stock">True</property>
                      </object>
                    </child>
+                    <child>
+                      <object class="GtkImageMenuItem" id="menubarFileNew">
+                        <property name="label">gtk-new</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>
                    <child>
                      <object class="GtkSeparatorMenuItem" id="separatormenuitem1">
                        <property name="visible">True</property>
@ -152,6 +189,15 @@
                        <property name="use_stock">True</property>
                      </object>
                    </child>
+                    <child>
+                      <object class="GtkImageMenuItem" id="menubarEditMove">
+                        <property name="label">Move</property>
+                        <property name="visible">True</property>
+                        <property name="can_focus">False</property>
+                        <property name="image">image2</property>
+                        <property name="use_stock">False</property>
+                      </object>
+                    </child>
                    <child>
                      <object class="GtkImageMenuItem" id="menubarEditPaste">
                        <property name="label">gtk-paste</property>
--- a/src/GUI/Gtk.hs
+++ b/src/GUI/Gtk.hs
@ -171,10 +171,14 @@ startMainWindow startdir = do
                       "menubarFileOpen"
  menubarFileExecute <- builderGetObject builder castToImageMenuItem
                        "menubarFileExecute"
+  menubarFileNew    <- builderGetObject builder castToImageMenuItem
+                       "menubarFileNew"
  menubarEditCut    <- builderGetObject builder castToImageMenuItem
                       "menubarEditCut"
  menubarEditCopy   <- builderGetObject builder castToImageMenuItem
                       "menubarEditCopy"
+  menubarEditMove   <- builderGetObject builder castToImageMenuItem
+                       "menubarEditMove"
  menubarEditPaste  <- builderGetObject builder castToImageMenuItem
                       "menubarEditPaste"
  menubarEditDelete <- builderGetObject builder castToImageMenuItem
@ -191,10 +195,14 @@ startMainWindow startdir = do
                       "rcFileOpen"
  rcFileExecute     <- builderGetObject builder castToImageMenuItem
                       "rcFileExecute"
+  rcFileNew         <- builderGetObject builder castToImageMenuItem
+                       "rcFileNew"
  rcFileCut         <- builderGetObject builder castToImageMenuItem
                       "rcFileCut"
  rcFileCopy        <- builderGetObject builder castToImageMenuItem
                       "rcFileCopy"
+  rcFileMove        <- builderGetObject builder castToImageMenuItem
+                       "rcFileMove"
  rcFilePaste       <- builderGetObject builder castToImageMenuItem
                       "rcFilePaste"
  rcFileDelete      <- builderGetObject builder castToImageMenuItem
--- a/src/GUI/Gtk/Callbacks.hs
+++ b/src/GUI/Gtk/Callbacks.hs
@ -85,10 +85,10 @@ setCallbacks mygui myview = do
  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
    [Control] <- eventModifier
    "h"       <- fmap glibToString eventKeyName
-    mcdir <- liftIO $ getFirstRow myview
+    cdir <- liftIO $ getCurrentDir myview
    liftIO $ modifyTVarIO (settings mygui)
                          (\x -> x { showHidden = not . showHidden $ x})
-             >> (refreshTreeView' mygui myview =<< goUp mcdir)
+             >> (refreshTreeView' mygui myview cdir)
  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
    [Alt] <- eventModifier
    "Up"  <- fmap glibToString eventKeyName
@ -117,10 +117,14 @@ setCallbacks mygui myview = do
    liftIO $ withRow mygui myview open
  _ <- menubarFileExecute mygui `on` menuItemActivated $
    liftIO $ withRow mygui myview execute
+  _ <- menubarFileNew mygui `on` menuItemActivated $
+    liftIO $ newFile mygui myview

  -- menubar-edit
  _ <- menubarEditCopy mygui `on` menuItemActivated $
    liftIO $ withRow mygui myview copyInit
+  _ <- menubarEditMove mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview moveInit
  _ <- menubarEditPaste mygui `on` menuItemActivated $
    liftIO $ operationFinal mygui myview
  _ <- menubarEditDelete mygui `on` menuItemActivated $
@ -144,8 +148,12 @@ setCallbacks mygui myview = do
    liftIO $ withRow mygui myview open
  _ <- rcFileExecute mygui `on` menuItemActivated $
    liftIO $ withRow mygui myview execute
+  _ <- rcFileNew mygui `on` menuItemActivated $
+    liftIO $ newFile mygui myview
  _ <- rcFileCopy mygui `on` menuItemActivated $
    liftIO $ withRow mygui myview copyInit
+  _ <- rcFileMove mygui `on` menuItemActivated $
+    liftIO $ withRow mygui myview moveInit
  _ <- rcFilePaste mygui `on` menuItemActivated $
    liftIO $ operationFinal mygui myview
  _ <- rcFileDelete mygui `on` menuItemActivated $
@ -221,7 +229,7 @@ copyInit row mygui myview =
 operationFinal :: MyGUI -> MyView -> IO ()
 operationFinal mygui myview = withErrorDialog $ do
  op <- readTVarIO (operationBuffer myview)
-  cdir <- goUp =<< getFirstRow myview
+  cdir <- getCurrentDir myview
  case op of
    FMove (MP1 s) -> do
      let cmsg = "Really move \"" ++ fullPath s
@ -249,8 +257,19 @@ operationFinal mygui myview = withErrorDialog $ do
 -- * 'sortedModel' reads
 upDir :: MyGUI -> MyView -> IO ()
 upDir mygui myview = withErrorDialog $ do
-  cdir <- goUp =<< getFirstRow myview
+  cdir <- getCurrentDir myview
  rawModel'    <- readTVarIO $ rawModel myview
  sortedModel' <- readTVarIO $ sortedModel myview
  nv <- goUp cdir
  refreshTreeView' mygui myview nv
+
+
+-- |Go up one directory and visualize it in the treeView.
+newFile :: MyGUI -> MyView -> IO ()
+newFile mygui myview = withErrorDialog $ do
+  cdir <- getCurrentDir myview
+  mfn   <- fileChooserDialog
+  maybe (return ()) (\fn -> do
+    createFile cdir fn
+    refreshTreeView' mygui myview cdir
+    ) mfn
--- a/src/GUI/Gtk/Data.hs
+++ b/src/GUI/Gtk/Data.hs
@ -47,16 +47,20 @@ data MyGUI = MkMyGUI {
  , menubarFileQuit :: ImageMenuItem
  , menubarFileOpen :: ImageMenuItem
  , menubarFileExecute :: ImageMenuItem
+  , menubarFileNew :: ImageMenuItem
  , menubarEditCut :: ImageMenuItem
  , menubarEditCopy :: ImageMenuItem
+  , menubarEditMove :: ImageMenuItem
  , menubarEditPaste :: ImageMenuItem
  , menubarEditDelete :: ImageMenuItem
  , menubarHelpAbout :: ImageMenuItem
  , rcMenu :: Menu
  , rcFileOpen :: ImageMenuItem
  , rcFileExecute :: ImageMenuItem
+  , rcFileNew :: ImageMenuItem
  , rcFileCut :: ImageMenuItem
  , rcFileCopy :: ImageMenuItem
+  , rcFileMove :: ImageMenuItem
  , rcFilePaste :: ImageMenuItem
  , rcFileDelete :: ImageMenuItem
  , urlBar :: Entry
--- a/src/GUI/Gtk/Dialogs.hs
+++ b/src/GUI/Gtk/Dialogs.hs
@ -158,3 +158,26 @@ withErrorDialog io = do
         (\_ -> return ())
         r

+
+-- |Asks the user which directory copy mode he wants via dialog popup
+-- and returns 'DirCopyMode'.
+fileChooserDialog :: IO (Maybe String)
+fileChooserDialog = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    "Enter filename"
+  entry <- entryNew
+  cbox <- dialogGetActionArea chooserDialog
+  dialogAddButton chooserDialog "Create" (ResponseUser 0)
+  dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
+  boxPackStart (castToBox cbox) entry PackNatural 5
+  widgetShowAll chooserDialog
+  rID <- dialogRun chooserDialog
+  ret <- case rID of
+           -- TODO: make this more safe
+           ResponseUser 0 -> Just <$> entryGetText entry
+           ResponseUser 1 -> return Nothing
+  widgetDestroy chooserDialog
+  return ret
--- a/src/GUI/Gtk/Utils.hs
+++ b/src/GUI/Gtk/Utils.hs
@ -125,6 +125,12 @@ getFirstRow myview = do
  treeModelGetRow rawModel' iter


+-- |Currently unsafe. Gets the current directory via `getFirstRow` and `goUp`.
+getCurrentDir :: MyView
+              -> IO (AnchoredFile FileInfo)
+getCurrentDir myview = getFirstRow myview >>= goUp
+
+
 -- |Re-reads the current directory or the given one and updates the TreeView.
 --
 -- The operation may fail with:
--- a/src/IO/Error.hs
+++ b/src/IO/Error.hs
@ -63,6 +63,7 @@ data FmIOException = FileDoesNotExist String
                   | NotAFile String
                   | NotADir String
                   | DestinationInSource String String
+                   | FileDoesExist String
                   | DirDoesExist String
                   | IsSymlink String
  deriving (Show, Typeable)
@ -87,6 +88,11 @@ throwNotAbsolute :: FilePath -> IO ()
 throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp)


+throwFileDoesExist :: FilePath -> IO ()
+throwFileDoesExist fp =
+  whenM (doesFileExist fp) (throw $ FileDoesExist fp)
+
+
 throwDirDoesExist :: FilePath -> IO ()
 throwDirDoesExist fp =
  whenM (doesDirectoryExist fp) (throw $ DirDoesExist fp)
--- a/src/IO/File.hs
+++ b/src/IO/File.hs
@ -75,6 +75,19 @@ import System.Posix.Files
  , readSymbolicLink
  , fileAccess
  , getFileStatus
+  , groupReadMode
+  , groupWriteMode
+  , otherReadMode
+  , otherWriteMode
+  , ownerReadMode
+  , ownerWriteMode
+  , touchFile
+  , unionFileModes
+  )
+import System.Posix.IO
+  (
+    closeFd
+  , createFile
  )
 import System.Process
  (
@ -374,3 +387,27 @@ executeFile :: AnchoredFile FileInfo  -- ^ program
 executeFile prog@(_ :/ RegFile {}) args
  = Just <$> spawnProcess (fullPath prog) args
 executeFile _ _      = return Nothing
+
+
+
+
+    ---------------------
+    --[ File Creation ]--
+    ---------------------
+
+
+createFile :: AnchoredFile FileInfo -> FileName -> IO ()
+createFile _ "."  = return ()
+createFile _ ".." = return ()
+createFile (SADir td) fn = do
+  let fullp = fullPath td </> fn
+  throwFileDoesExist fullp
+  let uf   = unionFileModes
+      mode =      ownerWriteMode
+             `uf` ownerReadMode
+             `uf` groupWriteMode
+             `uf` groupReadMode
+             `uf` otherWriteMode
+             `uf` otherReadMode
+  fd <- System.Posix.IO.createFile fullp mode
+  closeFd fd