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

Restructure module layout

Browse Source
This commit is contained in:
Julian Ospald
2016-03-30 20:16:34 +02:00
parent efd2535ef9
commit 74a48b2668
15 changed files with 89 additions and 83 deletions
Download Patch File Download Diff File Expand all files Collapse all files

54
src/HSFM/GUI/Gtk.hs Normal file
View File

@@ -0,0 +1,54 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module Main where
import Graphics.UI.Gtk
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.MyGUI
import HSFM.GUI.Gtk.MyView
import Safe
(
headDef
)
import System.Environment
(
getArgs
)
main :: IO ()
main = do
_ <- initGUI
args <- getArgs
mygui <- createMyGUI
myview <- createMyView mygui createTreeView
refreshView mygui myview (Just $ headDef "/" args)
widgetShowAll (rootWin mygui)
_ <- mainGUI
return ()

332
src/HSFM/GUI/Gtk/Callbacks.hs Normal file
View File

@@ -0,0 +1,332 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Callbacks where
import Control.Applicative
(
(<$>)
, (<*>)
)
import Control.Concurrent.STM
(
readTVarIO
)
import Control.Exception
(
throw
)
import Control.Monad
(
void
, forM_
)
import Control.Monad.IO.Class
(
liftIO
)
import Data.Foldable
(
for_
)
import Graphics.UI.Gtk
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import System.FilePath
(
isAbsolute
, (</>)
)
import System.Glib.UTFString
(
glibToString
)
-----------------
--[ Callbacks ]--
-----------------
-- |Set callbacks, on hotkeys, events and stuff.
setCallbacks :: MyGUI -> MyView -> IO ()
setCallbacks mygui myview = do
view' <- readTVarIO $ view myview
case view' of
FMTreeView treeView -> do
_ <- treeView `on` rowActivated
$ (\_ _ -> withItems mygui myview open)
commonGuiEvents treeView
return ()
FMIconView iconView -> do
_ <- iconView `on` itemActivated
$ (\_ -> withItems mygui myview open)
commonGuiEvents iconView
return ()
menubarCallbacks
where
menubarCallbacks = do
-- menubar-file
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- menubarFileOpen mygui `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- menubarFileExecute mygui `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- menubarFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
-- menubar-edit
_ <- menubarEditCut mygui `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
_ <- menubarEditCopy mygui `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- menubarEditRename mygui `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- menubarEditPaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- menubarEditDelete mygui `on` menuItemActivated $
liftIO $ withItems mygui myview del
-- mewnubar-view
_ <- menubarViewIcon mygui `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- menubarViewTree mygui `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
-- menubar-help
_ <- menubarHelpAbout mygui `on` menuItemActivated $
liftIO showAboutDialog
return ()
commonGuiEvents view = do
-- GUI events
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- refreshViewB mygui `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview
refreshView' mygui myview cdir
_ <- clearStatusBar mygui `on` buttonActivated $ do
popStatusbar mygui
writeTVarIO (operationBuffer myview) None
-- key events
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> refreshView' mygui myview cdir
_ <- view `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- view `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview del
_ <- view `on` keyPressEvent $ tryEvent $ do
[] <- eventModifier
"Return" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview open
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview copyInit
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"x" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview moveInit
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
liftIO $ operationFinal mygui myview
-- righ-click
_ <- view `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
RightButton -> liftIO $ menuPopup (rcMenu mygui)
$ Just (RightButton, t)
_ -> return ()
return False
_ <- rcFileOpen mygui `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- rcFileExecute mygui `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- rcFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
_ <- rcFileCopy mygui `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- rcFileRename mygui `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- rcFilePaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- rcFileDelete mygui `on` menuItemActivated $
liftIO $ withItems mygui myview del
_ <- rcFileCut mygui `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
return ()
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar mygui)
let abs = isAbsolute fp
exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
-- TODO: more explicit error handling?
refreshView mygui myview (Just fp)
-- |Supposed to be used with 'withRows'. Opens a file or directory.
open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
ADirOrSym r -> do
nv <- HSFM.FileSystem.FileType.readFileWithFileInfo $ fullPath r
refreshView' mygui myview nv
r ->
void $ openFile r
-- this throws on the first error that occurs
open (FileLikeList fs) mygui myview = withErrorDialog $
forM_ fs $ \f -> void $ openFile f
open _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Execute a given file.
execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] mygui myview = withErrorDialog $
void $ executeFile item []
execute _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
del :: [Item] -> MyGUI -> MyView -> IO ()
del [item] mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ P.fromAbs (fullPath item) ++ "\"?"
withConfirmationDialog cmsg
$ easyDelete item
-- this throws on the first error that occurs
del items@(_:_) mygui myview = withErrorDialog $ do
let cmsg = "Really delete " ++ show (length items) ++ " files?"
withConfirmationDialog cmsg
$ forM_ items $ \item -> easyDelete item
del _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Initializes a file move operation.
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
moveInit [item] mygui myview = do
writeTVarIO (operationBuffer myview) (FMove . MP1 $ item)
let sbmsg = "Move buffer: " ++ P.fromAbs (fullPath item)
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
moveInit _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
copyInit [item] mygui myview = do
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item)
let sbmsg = "Copy buffer: " ++ P.fromAbs (fullPath item)
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
copyInit _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Finalizes a file operation, such as copy or move.
operationFinal :: MyGUI -> MyView -> IO ()
operationFinal mygui myview = withErrorDialog $ do
op <- readTVarIO (operationBuffer myview)
cdir <- getCurrentDir myview
case op of
FMove (MP1 s) -> do
let cmsg = "Really move \"" ++ P.fromAbs (fullPath s)
++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
return ()
FCopy (CP1 s) -> do
let cmsg = "Really copy \"" ++ P.fromAbs (fullPath s)
++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
return ()
_ -> return ()
-- |Go up one directory and visualize it in the treeView.
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
nv <- goUp cdir
refreshView' mygui myview nv
-- |Go up one directory and visualize it in the treeView.
newFile :: MyGUI -> MyView -> IO ()
newFile mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name"
let pmfn = P.parseFn =<< mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createFile cdir fn
renameF :: [Item] -> MyGUI -> MyView -> IO ()
renameF [item] mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name"
let pmfn = P.parseFn =<< mfn
for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ P.fromAbs (fullPath item)
++ "\"" ++ " to \"" ++ P.fromAbs (anchor item P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $
HSFM.FileSystem.FileOperations.renameFile item fn
renameF _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"

25
src/HSFM/GUI/Gtk/Callbacks.hs-boot Normal file
View File

@@ -0,0 +1,25 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
module HSFM.GUI.Gtk.Callbacks where
import HSFM.GUI.Gtk.Data
setCallbacks :: MyGUI -> MyView -> IO ()

111
src/HSFM/GUI/Gtk/Data.hs Normal file
View File

@@ -0,0 +1,111 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Data where
import Control.Concurrent.MVar
(
MVar
)
import Control.Concurrent.STM
(
TVar
)
import Graphics.UI.Gtk
import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType
import System.INotify
(
INotify
)
------------------
--[ Base Types ]--
------------------
-- |Monolithic object passed to various GUI functions in order
-- to keep the API stable and not alter the parameters too much.
-- This only holds GUI widgets that are needed to be read during
-- runtime.
data MyGUI = MkMyGUI {
-- |main Window
rootWin :: Window
, menubarFileQuit :: ImageMenuItem
, menubarFileOpen :: ImageMenuItem
, menubarFileExecute :: ImageMenuItem
, menubarFileNew :: ImageMenuItem
, menubarEditCut :: ImageMenuItem
, menubarEditCopy :: ImageMenuItem
, menubarEditRename :: ImageMenuItem
, menubarEditPaste :: ImageMenuItem
, menubarEditDelete :: ImageMenuItem
, menubarViewTree :: ImageMenuItem
, menubarViewIcon :: ImageMenuItem
, menubarHelpAbout :: ImageMenuItem
, rcMenu :: Menu
, rcFileOpen :: ImageMenuItem
, rcFileExecute :: ImageMenuItem
, rcFileNew :: ImageMenuItem
, rcFileCut :: ImageMenuItem
, rcFileCopy :: ImageMenuItem
, rcFileRename :: ImageMenuItem
, rcFilePaste :: ImageMenuItem
, rcFileDelete :: ImageMenuItem
, refreshViewB :: Button
, urlBar :: Entry
, statusBar :: Statusbar
, clearStatusBar :: Button
, settings :: TVar FMSettings
, scroll :: ScrolledWindow
}
-- |FM-wide settings.
data FMSettings = MkFMSettings {
showHidden :: Bool
, isLazy :: Bool
, iconSize :: Int
}
data FMView = FMTreeView TreeView
| FMIconView IconView
type Item = AnchoredFile FileInfo
-- |This describes the contents of the current vie and is separated from MyGUI,
-- because we might want to have multiple views.
data MyView = MkMyView {
view :: TVar FMView
, rawModel :: TVar (ListStore Item)
, sortedModel :: TVar (TypedTreeModelSort Item)
, filteredModel :: TVar (TypedTreeModelFilter Item)
, operationBuffer :: TVar FileOperation
, inotify :: MVar INotify
}
fmViewToContainer :: FMView -> Container
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x

209
src/HSFM/GUI/Gtk/Dialogs.hs Normal file
View File

@@ -0,0 +1,209 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Dialogs where
import Control.Applicative
(
(<$>)
)
import Control.Exception
(
catch
, throw
, try
, SomeException
)
import Control.Monad
(
when
, void
)
import Data.Version
(
showVersion
)
import Distribution.Package
(
PackageIdentifier(..)
, PackageName(..)
)
import Distribution.PackageDescription
(
GenericPackageDescription(..)
, PackageDescription(..)
)
import Distribution.PackageDescription.Parse
(
readPackageDescription
)
import Distribution.Verbosity
(
silent
)
import Graphics.UI.Gtk
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
import HSFM.GUI.Gtk.Data
import Paths_hsfm
(
getDataFileName
)
---------------------
--[ Dialog popups ]--
---------------------
-- |Pops up an error Dialog with the given String.
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
-- |Asks the user for confirmation and returns True/False.
showConfirmationDialog :: String -> IO Bool
showConfirmationDialog str = do
confirmDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsYesNo
str
rID <- dialogRun confirmDialog
widgetDestroy confirmDialog
case rID of
ResponseYes -> return True
ResponseNo -> return False
_ -> return False
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
showCopyModeDialog :: IO CopyMode
showCopyModeDialog = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
"Target exists, how to proceed?"
dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
dialogAddButton chooserDialog "Merge" (ResponseUser 1)
dialogAddButton chooserDialog "Replace" (ResponseUser 2)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Strict
ResponseUser 1 -> return Merge
ResponseUser 2 -> return Replace
-- |Attempts to run the given function with the `Strict` copy mode.
-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
-- the user for action via `showCopyModeDialog` and then carries out
-- the given function again.
withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
withCopyModeDialog fa =
catch (fa Strict) $ \e ->
case e of
FileDoesExist _ -> doIt
DirDoesExist _ -> doIt
e -> throw e
where
doIt = do cm <- showCopyModeDialog
case cm of
Strict -> return () -- don't try again
_ -> fa cm
-- |Shows the about dialog from the help menu.
showAboutDialog :: IO ()
showAboutDialog = do
ad <- aboutDialogNew
lstr <- readFile =<< getDataFileName "LICENSE"
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
pdesc <- fmap packageDescription
(readPackageDescription silent
=<< getDataFileName "hsfm.cabal")
set ad
[ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc
, aboutDialogName := (unPackageName . pkgName . package) pdesc
, aboutDialogVersion := (showVersion . pkgVersion . package) pdesc
, aboutDialogCopyright := copyright pdesc
, aboutDialogComments := description pdesc
, aboutDialogLicense := Just lstr
, aboutDialogWebsite := homepage pdesc
, aboutDialogAuthors := [author pdesc]
, aboutDialogLogo := Just hsfmicon
, aboutDialogWrapLicense := True
]
_ <- dialogRun ad
widgetDestroy ad
-- |Carry out an IO action with a confirmation dialog.
-- If the user presses "No", then do nothing.
withConfirmationDialog :: String -> IO () -> IO ()
withConfirmationDialog str io = do
run <- showConfirmationDialog str
when run io
-- |Execute the given IO action. If the action throws exceptions,
-- visualize them via 'showErrorDialog'.
withErrorDialog :: IO a -> IO ()
withErrorDialog io = do
r <- try io
either (\e -> showErrorDialog $ show (e :: SomeException))
(\_ -> return ())
r
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
textInputDialog :: String -> IO (Maybe String)
textInputDialog title = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
title
entry <- entryNew
cbox <- dialogGetActionArea chooserDialog
dialogAddButton chooserDialog "Ok" (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

72
src/HSFM/GUI/Gtk/Icons.hs Normal file
View File

@@ -0,0 +1,72 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |Module for Gtk icon handling.
module HSFM.GUI.Gtk.Icons where
import Data.Maybe
(
fromJust
)
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.Pixbuf
import Paths_hsfm
(
getDataFileName
)
-- |Icon type we use in our GUI.
data GtkIcon = IFolder
| SymL
| IFile
| IError
-- |Gets an icon from the default icon theme and falls back to project-icons
-- if not found. The requested icon size is not guaranteed.
getIcon :: GtkIcon -- ^ icon we want
-> IconTheme -- ^ which icon theme to get the icon from
-> Int -- ^ requested icon size
-> IO Pixbuf
getIcon icon itheme isize = do
let iname = iconToStr icon
hasicon <- iconThemeHasIcon itheme iname
case hasicon of
True -> fromJust <$> iconThemeLoadIcon itheme iname isize
IconLookupUseBuiltin
False -> pixbufNewFromFile =<< getDataFileName
("data/Gtk/icons/" ++ iname ++ ".png")
where
iconToStr IFolder = "gtk-directory"
iconToStr IFile = "gtk-file"
iconToStr IError = "error"
iconToStr SymL = "emblem-symbolic-link"
getSymlinkIcon :: GtkIcon -> IconTheme -> Int -> IO Pixbuf
getSymlinkIcon icon itheme isize = do
pix <- pixbufCopy =<< getIcon icon itheme isize
sympix <- getIcon SymL itheme isize
pixbufScale sympix pix 0 0 12 12 0 0 0.5 0.5 InterpNearest
return pix

115
src/HSFM/GUI/Gtk/MyGUI.hs Normal file
View File

@@ -0,0 +1,115 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.MyGUI where
import Control.Concurrent.STM
(
newTVarIO
)
import Graphics.UI.Gtk
import HSFM.GUI.Gtk.Data
import Paths_hsfm
(
getDataFileName
)
-------------------------
--[ Main Window Setup ]--
-------------------------
-- |Set up the GUI. This only creates the permanent widgets.
createMyGUI :: IO MyGUI
createMyGUI = do
let settings' = MkFMSettings False True 24
settings <- newTVarIO settings'
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-- get the pre-defined gui widgets
rootWin <- builderGetObject builder castToWindow
"rootWin"
scroll <- builderGetObject builder castToScrolledWindow
"mainScroll"
menubarFileQuit <- builderGetObject builder castToImageMenuItem
"menubarFileQuit"
menubarFileOpen <- builderGetObject builder castToImageMenuItem
"menubarFileOpen"
menubarFileExecute <- builderGetObject builder castToImageMenuItem
"menubarFileExecute"
menubarFileNew <- builderGetObject builder castToImageMenuItem
"menubarFileNew"
menubarEditCut <- builderGetObject builder castToImageMenuItem
"menubarEditCut"
menubarEditCopy <- builderGetObject builder castToImageMenuItem
"menubarEditCopy"
menubarEditRename <- builderGetObject builder castToImageMenuItem
"menubarEditRename"
menubarEditPaste <- builderGetObject builder castToImageMenuItem
"menubarEditPaste"
menubarEditDelete <- builderGetObject builder castToImageMenuItem
"menubarEditDelete"
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
"menubarHelpAbout"
urlBar <- builderGetObject builder castToEntry
"urlBar"
statusBar <- builderGetObject builder castToStatusbar
"statusBar"
clearStatusBar <- builderGetObject builder castToButton
"clearStatusBar"
rcMenu <- builderGetObject builder castToMenu
"rcMenu"
rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNew <- builderGetObject builder castToImageMenuItem
"rcFileNew"
rcFileCut <- builderGetObject builder castToImageMenuItem
"rcFileCut"
rcFileCopy <- builderGetObject builder castToImageMenuItem
"rcFileCopy"
rcFileRename <- builderGetObject builder castToImageMenuItem
"rcFileRename"
rcFilePaste <- builderGetObject builder castToImageMenuItem
"rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete"
refreshViewB <- builderGetObject builder castToButton
"refreshViewB"
menubarViewTree <- builderGetObject builder castToImageMenuItem
"menubarViewTree"
menubarViewIcon <- builderGetObject builder castToImageMenuItem
"menubarViewIcon"
-- construct the gui object
let mygui = MkMyGUI {..}
-- sets the default icon
windowSetDefaultIconFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
return mygui

322
src/HSFM/GUI/Gtk/MyView.hs Normal file
View File

@@ -0,0 +1,322 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.MyView where
import Control.Applicative
(
(<$>)
)
import Control.Concurrent.MVar
(
newEmptyMVar
, putMVar
, tryTakeMVar
)
import Control.Concurrent.STM
(
newTVarIO
, readTVarIO
)
import Data.Foldable
(
for_
)
import Data.Maybe
(
catMaybes
, fromJust
, fromMaybe
)
import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
import qualified HPath as P
import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import System.FilePath
(
isAbsolute
)
import System.INotify
(
addWatch
, initINotify
, killINotify
, EventVariety(..)
, Event(..)
)
-- |Constructs the initial MyView object with a few dummy models.
-- It also initializes the callbacks.
createMyView :: MyGUI -> IO FMView -> IO MyView
createMyView mygui iofmv = do
operationBuffer <- newTVarIO None
inotify <- newEmptyMVar
-- create dummy models, so we don't have to use MVar
rawModel <- newTVarIO =<< listStoreNew []
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
=<< readTVarIO rawModel
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
=<< readTVarIO filteredModel
view' <- iofmv
view <- newTVarIO view'
let myview = MkMyView {..}
-- set the bindings
setCallbacks mygui myview
-- add the treeview to the scroll container
let oview = fmViewToContainer view'
containerAdd (scroll mygui) oview
return myview
-- |Switch the existing view in `MyView` with the one that the
-- io action returns.
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
switchView mygui myview iofmv = do
view' <- readTVarIO $ view myview
let oview = fmViewToContainer view'
widgetDestroy oview
nview' <- iofmv
let nview = fmViewToContainer nview'
writeTVarIO (view myview) nview'
setCallbacks mygui myview
containerAdd (scroll mygui) nview
widgetShow nview
refreshView mygui myview Nothing
-- |Createss an IconView.
createIconView :: IO FMView
createIconView = do
iconv <- iconViewNew
iconViewSetSelectionMode iconv SelectionMultiple
iconViewSetColumns iconv (-1)
iconViewSetSpacing iconv 2
iconViewSetMargin iconv 0
{- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
{- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
return $ FMIconView iconv
-- |Creates a TreeView.
createTreeView :: IO FMView
createTreeView = do
-- create the final view
treeView <- treeViewNew
-- set selection mode
tvs <- treeViewGetSelection treeView
treeSelectionSetMode tvs SelectionMultiple
-- create final tree model columns
renderTxt <- cellRendererTextNew
renderPix <- cellRendererPixbufNew
let ct = cellText :: (CellRendererTextClass cr) => Attr cr String
cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
-- filename column
cF <- treeViewColumnNew
treeViewColumnSetTitle cF "Filename"
treeViewColumnSetResizable cF True
treeViewColumnSetClickable cF True
treeViewColumnSetSortColumnId cF 1
cellLayoutPackStart cF renderPix False
cellLayoutPackStart cF renderTxt True
_ <- treeViewAppendColumn treeView cF
cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
-- date column
cMD <- treeViewColumnNew
treeViewColumnSetTitle cMD "Date"
treeViewColumnSetResizable cMD True
treeViewColumnSetClickable cMD True
treeViewColumnSetSortColumnId cMD 2
cellLayoutPackStart cMD renderTxt True
_ <- treeViewAppendColumn treeView cMD
cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
-- permissions column
cP <- treeViewColumnNew
treeViewColumnSetTitle cP "Permission"
treeViewColumnSetResizable cP True
treeViewColumnSetClickable cP True
treeViewColumnSetSortColumnId cP 3
cellLayoutPackStart cP renderTxt True
_ <- treeViewAppendColumn treeView cP
cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
return $ FMTreeView treeView
-- |Re-reads the current directory or the given one and updates the View.
refreshView :: MyGUI
-> MyView
-> Maybe FilePath
-> IO ()
refreshView mygui myview mfp =
case mfp of
Just fp -> do
let mdir = fromMaybe (fromJust $ P.parseAbs "/") (P.parseAbs fp)
cdir <- HSFM.FileSystem.FileType.readFileWithFileInfo mdir
refreshView' mygui myview cdir
Nothing -> refreshView' mygui myview =<< getCurrentDir myview
-- |Refreshes the View based on the given directory.
refreshView' :: MyGUI
-> MyView
-> AnchoredFile FileInfo
-> IO ()
refreshView' mygui myview dt@(ADirOrSym _) = do
newRawModel <- fileListStore dt myview
writeTVarIO (rawModel myview) newRawModel
view' <- readTVarIO $ view myview
-- get selected items
tps <- getSelectedTreePaths mygui myview
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
constructView mygui myview
-- reselect selected items
-- TODO: not implemented for icon view yet
case view' of
FMTreeView treeView -> do
tvs <- treeViewGetSelection treeView
ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return ()
refreshView' _ _ _ = return ()
-- |Constructs the visible View with the current underlying mutable models,
-- which are retrieved from 'MyGUI'.
--
-- This sort of merges the components mygui and myview and fires up
-- the actual models.
constructView :: MyGUI
-> MyView
-> IO ()
constructView mygui myview = do
settings' <- readTVarIO $ settings mygui
-- pix stuff
iT <- iconThemeGetDefault
folderPix <- getIcon IFolder iT (iconSize settings')
folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
filePix <- getIcon IFile iT (iconSize settings')
fileSymPix <- getSymlinkIcon IFile iT (iconSize settings')
errorPix <- getIcon IError iT (iconSize settings')
let dirtreePix (Dir {}) = folderPix
dirtreePix (FileLike {}) = filePix
dirtreePix (DirSym _) = folderSymPix
dirtreePix (FileLikeSym {}) = fileSymPix
dirtreePix (Failed {}) = errorPix
dirtreePix (BrokenSymlink _) = errorPix
dirtreePix _ = errorPix
view' <- readTVarIO $ view myview
cdirp <- anchor <$> getFirstItem myview
-- update urlBar
entrySetText (urlBar mygui) (P.fromAbs cdirp)
rawModel' <- readTVarIO $ rawModel myview
-- filtering
filteredModel' <- treeModelFilterNew rawModel' []
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
item <- (name . file) <$> treeModelGetRow rawModel' iter
if hidden
then return True
else return $ not . hiddenFile $ item
-- sorting
sortedModel' <- treeModelSortNewWithModel filteredModel'
writeTVarIO (sortedModel myview) sortedModel'
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
item1 <- treeModelGetRow rawModel' cIter1
item2 <- treeModelGetRow rawModel' cIter2
return $ compare item1 item2
treeSortableSetSortColumnId sortedModel' 1 SortAscending
-- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . file)
treeModelSetColumn rawModel' (makeColumnIdString 1)
(P.fromRel . name . file)
treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . file)
treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . file)
-- update model of view
case view' of
FMTreeView treeView -> do
treeViewSetModel treeView sortedModel'
treeViewSetRubberBanding treeView True
FMIconView iconView -> do
iconViewSetModel iconView (Just sortedModel')
iconViewSetPixbufColumn iconView
(makeColumnIdPixbuf 0 :: ColumnId item Pixbuf)
iconViewSetTextColumn iconView
(makeColumnIdString 1 :: ColumnId item String)
-- add watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
newi <- initINotify
w <- addWatch
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
(P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ P.fromAbs cdirp))
putMVar (inotify myview) newi
return ()

148
src/HSFM/GUI/Gtk/Utils.hs Normal file
View File

@@ -0,0 +1,148 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Utils where
import Control.Applicative
(
(<$>)
)
import Control.Concurrent.STM
(
readTVarIO
)
import Data.Maybe
(
catMaybes
, fromJust
)
import Data.Traversable
(
forM
)
import Graphics.UI.Gtk
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data
-----------------
--[ Utilities ]--
-----------------
getSelectedTreePaths :: MyGUI -> MyView -> IO [TreePath]
getSelectedTreePaths _ myview = do
view' <- readTVarIO $ view myview
case view' of
FMTreeView treeView -> do
tvs <- treeViewGetSelection treeView
treeSelectionGetSelectedRows tvs
FMIconView iconView ->
iconViewGetSelectedItems iconView
-- |Gets the currently selected item of the treeView, if any.
getSelectedItems :: MyGUI
-> MyView
-> IO [Item]
getSelectedItems mygui myview = do
tps <- getSelectedTreePaths mygui myview
getSelectedItems' mygui myview tps
getSelectedItems' :: MyGUI
-> MyView
-> [TreePath]
-> IO [Item]
getSelectedItems' mygui myview tps = do
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
filteredModel' <- readTVarIO $ filteredModel myview
iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
forM iters $ \iter -> do
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
treeModelGetRow rawModel' cIter
-- |Carry out an action on the currently selected item.
--
-- If there is no item selected, does nothing.
withItems :: MyGUI
-> MyView
-> ( [Item]
-> MyGUI
-> MyView
-> IO ()) -- ^ action to carry out
-> IO ()
withItems mygui myview io = do
items <- getSelectedItems mygui myview
io items mygui myview
-- |Create the 'ListStore' of files/directories from the current directory.
-- This is the function which maps the Data.DirTree data structures
-- into the GTK+ data structures.
fileListStore :: AnchoredFile FileInfo -- ^ current dir
-> MyView
-> IO (ListStore Item)
fileListStore dt myview = do
cs <- HSFM.FileSystem.FileType.getContents dt
listStoreNew cs
-- |Currently unsafe. This is used to obtain any item (possibly the '.' item)
-- and extract the "current working directory" from it.
getFirstItem :: MyView
-> IO (AnchoredFile FileInfo)
getFirstItem myview = do
rawModel' <- readTVarIO $ rawModel myview
iter <- fromJust <$> treeModelGetIterFirst rawModel'
treeModelGetRow rawModel' iter
-- |Currently unsafe. Gets the current directory via `getFirstItem` and
-- `goUp`.
getCurrentDir :: MyView
-> IO (AnchoredFile FileInfo)
getCurrentDir myview = getFirstItem myview >>= goUp
-- |Push a message to the status bar.
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
pushStatusBar mygui str = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
mid <- statusbarPush sb cid str
return (cid, mid)
-- |Pop a message from the status bar.
popStatusbar :: MyGUI -> IO ()
popStatusbar mygui = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
statusbarPop sb cid