From 71a2cb90be22a67f18817defbb2b8dcaea07f550 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 25 Dec 2015 22:51:45 +0100 Subject: [PATCH] LIB/GTK: add move menuitem and implement creating new files --- data/Gtk/builder.xml | 46 ++++++++++++++++++++++++++++++++++++++++ src/GUI/Gtk.hs | 8 +++++++ src/GUI/Gtk/Callbacks.hs | 27 +++++++++++++++++++---- src/GUI/Gtk/Data.hs | 4 ++++ src/GUI/Gtk/Dialogs.hs | 23 ++++++++++++++++++++ src/GUI/Gtk/Utils.hs | 6 ++++++ src/IO/Error.hs | 6 ++++++ src/IO/File.hs | 37 ++++++++++++++++++++++++++++++++ 8 files changed, 153 insertions(+), 4 deletions(-) diff --git a/data/Gtk/builder.xml b/data/Gtk/builder.xml index c55347b..e5d6f03 100644 --- a/data/Gtk/builder.xml +++ b/data/Gtk/builder.xml @@ -2,6 +2,11 @@ + + True + False + gtk-edit + True False @@ -23,6 +28,15 @@ True + + + gtk-new + True + False + True + True + + True @@ -47,6 +61,15 @@ True + + + Move + True + False + image1 + False + + gtk-paste @@ -66,6 +89,11 @@ + + True + False + gtk-edit + False @@ -105,6 +133,15 @@ True + + + gtk-new + True + False + True + True + + True @@ -152,6 +189,15 @@ True + + + Move + True + False + image2 + False + + gtk-paste diff --git a/src/GUI/Gtk.hs b/src/GUI/Gtk.hs index e6e2a16..4766b11 100644 --- 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 diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs index 4c090ce..7c9277e 100644 --- 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 diff --git a/src/GUI/Gtk/Data.hs b/src/GUI/Gtk/Data.hs index f760cd4..4ea4344 100644 --- 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 diff --git a/src/GUI/Gtk/Dialogs.hs b/src/GUI/Gtk/Dialogs.hs index fcd6246..7e48395 100644 --- 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 diff --git a/src/GUI/Gtk/Utils.hs b/src/GUI/Gtk/Utils.hs index 121967b..78b2692 100644 --- 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: diff --git a/src/IO/Error.hs b/src/IO/Error.hs index 3652e84..8d4fd20 100644 --- 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) diff --git a/src/IO/File.hs b/src/IO/File.hs index d710dcf..ee49d08 100644 --- 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