GTK: restructure modules a bit
This commit is contained in:
parent
1aeb92d657
commit
06b96eecea
@ -52,7 +52,6 @@ executable hsfm-gtk
|
|||||||
other-modules: GUI.Gtk.Callbacks
|
other-modules: GUI.Gtk.Callbacks
|
||||||
GUI.Gtk.Data
|
GUI.Gtk.Data
|
||||||
GUI.Gtk.Dialogs
|
GUI.Gtk.Dialogs
|
||||||
GUI.Gtk.Gui
|
|
||||||
GUI.Gtk.Icons
|
GUI.Gtk.Icons
|
||||||
GUI.Gtk.Utils
|
GUI.Gtk.Utils
|
||||||
MyPrelude
|
MyPrelude
|
||||||
|
|||||||
214
src/GUI/Gtk.hs
214
src/GUI/Gtk.hs
@ -2,16 +2,102 @@
|
|||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
(
|
||||||
|
(<$>)
|
||||||
|
, (<*>)
|
||||||
|
)
|
||||||
|
import Control.Concurrent
|
||||||
|
(
|
||||||
|
forkIO
|
||||||
|
)
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
(
|
||||||
|
TVar
|
||||||
|
, newTVarIO
|
||||||
|
, readTVarIO
|
||||||
|
)
|
||||||
|
import Control.Exception
|
||||||
|
(
|
||||||
|
try
|
||||||
|
, Exception
|
||||||
|
, SomeException
|
||||||
|
)
|
||||||
|
import Control.Monad
|
||||||
|
(
|
||||||
|
when
|
||||||
|
, void
|
||||||
|
)
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
(
|
||||||
|
liftIO
|
||||||
|
)
|
||||||
|
import Data.DirTree
|
||||||
|
import Data.Foldable
|
||||||
|
(
|
||||||
|
for_
|
||||||
|
)
|
||||||
|
import Data.List
|
||||||
|
(
|
||||||
|
sort
|
||||||
|
, isPrefixOf
|
||||||
|
)
|
||||||
|
import Data.Maybe
|
||||||
|
(
|
||||||
|
fromJust
|
||||||
|
, catMaybes
|
||||||
|
, fromMaybe
|
||||||
|
)
|
||||||
|
import Data.Traversable
|
||||||
|
(
|
||||||
|
forM
|
||||||
|
)
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
import GUI.Gtk.Gui
|
import GUI.Gtk.Callbacks
|
||||||
|
import GUI.Gtk.Data
|
||||||
|
import GUI.Gtk.Dialogs
|
||||||
|
import GUI.Gtk.Icons
|
||||||
|
import GUI.Gtk.Utils
|
||||||
|
import IO.Error
|
||||||
|
import IO.File
|
||||||
|
import IO.Utils
|
||||||
|
import MyPrelude
|
||||||
import Safe
|
import Safe
|
||||||
(
|
(
|
||||||
headDef
|
headDef
|
||||||
)
|
)
|
||||||
|
import System.Directory
|
||||||
|
(
|
||||||
|
executable
|
||||||
|
, doesFileExist
|
||||||
|
, doesDirectoryExist
|
||||||
|
)
|
||||||
import System.Environment
|
import System.Environment
|
||||||
(
|
(
|
||||||
getArgs
|
getArgs
|
||||||
)
|
)
|
||||||
|
import System.FilePath
|
||||||
|
(
|
||||||
|
isAbsolute
|
||||||
|
, (</>)
|
||||||
|
)
|
||||||
|
import System.Glib.UTFString
|
||||||
|
(
|
||||||
|
glibToString
|
||||||
|
)
|
||||||
|
import System.IO.Unsafe
|
||||||
|
(
|
||||||
|
unsafePerformIO
|
||||||
|
)
|
||||||
|
import System.Process
|
||||||
|
(
|
||||||
|
spawnProcess
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: simplify where we modify the TVars
|
||||||
|
-- TODO: double check garbage collection/gtk ref counting
|
||||||
|
-- TODO: file watching, when and what to reread
|
||||||
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
@ -22,4 +108,128 @@ main = do
|
|||||||
|
|
||||||
startMainWindow (headDef "/" args)
|
startMainWindow (headDef "/" args)
|
||||||
|
|
||||||
mainGUI
|
_ <- mainGUI
|
||||||
|
return ()
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------
|
||||||
|
--[ Main Window Setup ]--
|
||||||
|
-------------------------
|
||||||
|
|
||||||
|
|
||||||
|
-- |Set up the GUI.
|
||||||
|
--
|
||||||
|
-- Interaction with mutable references:
|
||||||
|
--
|
||||||
|
-- * 'settings' creates
|
||||||
|
-- * 'operationBuffer' creates
|
||||||
|
-- * 'rawModel' creates
|
||||||
|
-- * 'filteredModel' creates
|
||||||
|
-- * 'sortedModel' creates
|
||||||
|
startMainWindow :: FilePath -> IO ()
|
||||||
|
startMainWindow startdir = do
|
||||||
|
|
||||||
|
settings <- newTVarIO (MkFMSettings False True)
|
||||||
|
|
||||||
|
-- get the icons
|
||||||
|
iT <- iconThemeGetDefault
|
||||||
|
folderPix <- getIcon IFolder 24
|
||||||
|
filePix <- getIcon IFile 24
|
||||||
|
errorPix <- getIcon IError 24
|
||||||
|
|
||||||
|
operationBuffer <- newTVarIO None
|
||||||
|
|
||||||
|
builder <- builderNew
|
||||||
|
builderAddFromFile builder "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"
|
||||||
|
menubarFileCut <- builderGetObject builder castToImageMenuItem
|
||||||
|
"menubarFileCut"
|
||||||
|
menubarFileCopy <- builderGetObject builder castToImageMenuItem
|
||||||
|
"menubarFileCopy"
|
||||||
|
menubarFilePaste <- builderGetObject builder castToImageMenuItem
|
||||||
|
"menubarFilePaste"
|
||||||
|
menubarFileDelete <- builderGetObject builder castToImageMenuItem
|
||||||
|
"menubarFileDelete"
|
||||||
|
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
|
||||||
|
"menubarHelpAbout"
|
||||||
|
urlBar <- builderGetObject builder castToEntry
|
||||||
|
"urlBar"
|
||||||
|
statusBar <- builderGetObject builder castToStatusbar
|
||||||
|
"statusBar"
|
||||||
|
|
||||||
|
-- create initial list store model with unsorted data
|
||||||
|
rawModel <- newTVarIO =<< listStoreNew
|
||||||
|
=<< Data.DirTree.getContents
|
||||||
|
=<< Data.DirTree.readFile startdir
|
||||||
|
|
||||||
|
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
|
||||||
|
=<< readTVarIO rawModel
|
||||||
|
|
||||||
|
-- create an initial sorting proxy model
|
||||||
|
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
|
||||||
|
=<< readTVarIO filteredModel
|
||||||
|
|
||||||
|
-- create the final view
|
||||||
|
treeView <- treeViewNew
|
||||||
|
|
||||||
|
-- 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
|
||||||
|
|
||||||
|
-- construct the gui object
|
||||||
|
let mygui = MkMyGUI {..}
|
||||||
|
let myview = MkMyView {..}
|
||||||
|
|
||||||
|
-- create the tree model with its contents
|
||||||
|
constructTreeView mygui myview
|
||||||
|
|
||||||
|
-- set the bindings
|
||||||
|
setCallbacks mygui myview
|
||||||
|
|
||||||
|
-- add the treeview to the scroll container
|
||||||
|
containerAdd scroll treeView
|
||||||
|
|
||||||
|
widgetShowAll rootWin
|
||||||
|
|||||||
@ -1,226 +0,0 @@
|
|||||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
||||||
|
|
||||||
-- |The main Gtk Gui module for creating the main window.
|
|
||||||
module GUI.Gtk.Gui (startMainWindow) where
|
|
||||||
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
(
|
|
||||||
(<$>)
|
|
||||||
, (<*>)
|
|
||||||
)
|
|
||||||
import Control.Concurrent
|
|
||||||
(
|
|
||||||
forkIO
|
|
||||||
)
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
(
|
|
||||||
TVar
|
|
||||||
, newTVarIO
|
|
||||||
, readTVarIO
|
|
||||||
)
|
|
||||||
import Control.Exception
|
|
||||||
(
|
|
||||||
try
|
|
||||||
, Exception
|
|
||||||
, SomeException
|
|
||||||
)
|
|
||||||
import Control.Monad
|
|
||||||
(
|
|
||||||
when
|
|
||||||
, void
|
|
||||||
)
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
(
|
|
||||||
liftIO
|
|
||||||
)
|
|
||||||
import Data.DirTree
|
|
||||||
import Data.Foldable
|
|
||||||
(
|
|
||||||
for_
|
|
||||||
)
|
|
||||||
import Data.List
|
|
||||||
(
|
|
||||||
sort
|
|
||||||
, isPrefixOf
|
|
||||||
)
|
|
||||||
import Data.Maybe
|
|
||||||
(
|
|
||||||
fromJust
|
|
||||||
, catMaybes
|
|
||||||
, fromMaybe
|
|
||||||
)
|
|
||||||
import Data.Traversable
|
|
||||||
(
|
|
||||||
forM
|
|
||||||
)
|
|
||||||
import Graphics.UI.Gtk
|
|
||||||
import GUI.Gtk.Callbacks
|
|
||||||
import GUI.Gtk.Data
|
|
||||||
import GUI.Gtk.Dialogs
|
|
||||||
import GUI.Gtk.Icons
|
|
||||||
import GUI.Gtk.Utils
|
|
||||||
import IO.Error
|
|
||||||
import IO.File
|
|
||||||
import IO.Utils
|
|
||||||
import MyPrelude
|
|
||||||
import System.Directory
|
|
||||||
(
|
|
||||||
executable
|
|
||||||
, doesFileExist
|
|
||||||
, doesDirectoryExist
|
|
||||||
)
|
|
||||||
import System.Environment
|
|
||||||
(
|
|
||||||
getArgs
|
|
||||||
)
|
|
||||||
import System.FilePath
|
|
||||||
(
|
|
||||||
isAbsolute
|
|
||||||
, (</>)
|
|
||||||
)
|
|
||||||
import System.Glib.UTFString
|
|
||||||
(
|
|
||||||
glibToString
|
|
||||||
)
|
|
||||||
import System.IO.Unsafe
|
|
||||||
(
|
|
||||||
unsafePerformIO
|
|
||||||
)
|
|
||||||
import System.Process
|
|
||||||
(
|
|
||||||
spawnProcess
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- TODO: simplify where we modify the TVars
|
|
||||||
-- TODO: double check garbage collection/gtk ref counting
|
|
||||||
-- TODO: file watching, when and what to reread
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-------------------------
|
|
||||||
--[ Main Window Setup ]--
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
|
|
||||||
-- |Set up the GUI.
|
|
||||||
--
|
|
||||||
-- Interaction with mutable references:
|
|
||||||
--
|
|
||||||
-- * 'settings' creates
|
|
||||||
-- * 'operationBuffer' creates
|
|
||||||
-- * 'rawModel' creates
|
|
||||||
-- * 'filteredModel' creates
|
|
||||||
-- * 'sortedModel' creates
|
|
||||||
startMainWindow :: FilePath -> IO ()
|
|
||||||
startMainWindow startdir = do
|
|
||||||
|
|
||||||
settings <- newTVarIO (MkFMSettings False True)
|
|
||||||
|
|
||||||
-- get the icons
|
|
||||||
iT <- iconThemeGetDefault
|
|
||||||
folderPix <- getIcon IFolder 24
|
|
||||||
filePix <- getIcon IFile 24
|
|
||||||
errorPix <- getIcon IError 24
|
|
||||||
|
|
||||||
operationBuffer <- newTVarIO None
|
|
||||||
|
|
||||||
builder <- builderNew
|
|
||||||
builderAddFromFile builder "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"
|
|
||||||
menubarFileCut <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFileCut"
|
|
||||||
menubarFileCopy <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFileCopy"
|
|
||||||
menubarFilePaste <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFilePaste"
|
|
||||||
menubarFileDelete <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFileDelete"
|
|
||||||
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarHelpAbout"
|
|
||||||
urlBar <- builderGetObject builder castToEntry
|
|
||||||
"urlBar"
|
|
||||||
statusBar <- builderGetObject builder castToStatusbar
|
|
||||||
"statusBar"
|
|
||||||
|
|
||||||
-- create initial list store model with unsorted data
|
|
||||||
rawModel <- newTVarIO =<< listStoreNew
|
|
||||||
=<< Data.DirTree.getContents
|
|
||||||
=<< Data.DirTree.readFile startdir
|
|
||||||
|
|
||||||
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
|
|
||||||
=<< readTVarIO rawModel
|
|
||||||
|
|
||||||
-- create an initial sorting proxy model
|
|
||||||
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
|
|
||||||
=<< readTVarIO filteredModel
|
|
||||||
|
|
||||||
-- create the final view
|
|
||||||
treeView <- treeViewNew
|
|
||||||
|
|
||||||
-- 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
|
|
||||||
|
|
||||||
-- construct the gui object
|
|
||||||
let mygui = MkMyGUI {..}
|
|
||||||
let myview = MkMyView {..}
|
|
||||||
|
|
||||||
-- create the tree model with its contents
|
|
||||||
constructTreeView mygui myview
|
|
||||||
|
|
||||||
-- set the bindings
|
|
||||||
setCallbacks mygui myview
|
|
||||||
|
|
||||||
-- add the treeview to the scroll container
|
|
||||||
containerAdd scroll treeView
|
|
||||||
|
|
||||||
widgetShowAll rootWin
|
|
||||||
Loading…
Reference in New Issue
Block a user