Move gui related stuff to Gtk module
This commit is contained in:
parent
d0f524167a
commit
eaafccd544
125
Gtk.hs
Normal file
125
Gtk.hs
Normal file
@ -0,0 +1,125 @@
|
||||
module Gtk where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Diagram
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Backend.Cairo
|
||||
import Diagrams.Backend.Cairo.Internal
|
||||
import Graphics.UI.Gtk
|
||||
import Graphics.UI.Gtk.Windows.MessageDialog
|
||||
import System.Directory
|
||||
|
||||
|
||||
startGUI :: IO ()
|
||||
startGUI = do
|
||||
homedir <- getHomeDirectory
|
||||
|
||||
-- init gui
|
||||
_ <- initGUI
|
||||
|
||||
-- create window and widgets
|
||||
window <- windowNew
|
||||
da <- drawingAreaNew
|
||||
fileButton <- fileChooserButtonNew "Select mesh"
|
||||
FileChooserActionOpen
|
||||
drawButton <- buttonNew
|
||||
saveButton <- buttonNew
|
||||
quitButton <- buttonNew
|
||||
box1 <- vBoxNew False 0
|
||||
box2 <- hButtonBoxNew
|
||||
box3 <- hButtonBoxNew
|
||||
drawButtonLabel <- labelNew $ Just "Draw"
|
||||
saveButtonLabel <- labelNew $ Just "Save"
|
||||
quitButtonLabel <- labelNew $ Just "Quit"
|
||||
|
||||
-- containers and boxing
|
||||
containerAdd drawButton drawButtonLabel
|
||||
containerAdd saveButton saveButtonLabel
|
||||
containerAdd quitButton quitButtonLabel
|
||||
containerAdd window box1
|
||||
boxPackStart box1 da PackGrow 0
|
||||
boxPackStart box1 box2 PackNatural 0
|
||||
boxPackStart box1 box3 PackNatural 0
|
||||
boxPackStart box2 drawButton PackNatural 0
|
||||
boxPackStart box2 saveButton PackNatural 0
|
||||
boxPackStart box2 quitButton PackNatural 0
|
||||
boxPackStart box3 fileButton PackNatural 0
|
||||
|
||||
-- adjust properties
|
||||
set window [windowDefaultWidth := 600, windowDefaultHeight := 700,
|
||||
windowTitle := "Computergrafik"]
|
||||
set box2 [buttonBoxLayoutStyle := ButtonboxCenter]
|
||||
set box3 [buttonBoxLayoutStyle := ButtonboxCenter]
|
||||
_ <- windowSetTypeHint window WindowTypeHintDialog
|
||||
containerSetBorderWidth box2 10
|
||||
_ <- fileChooserSetCurrentFolder fileButton homedir
|
||||
|
||||
-- callbacks
|
||||
_ <- onDestroy window mainQuit
|
||||
_ <- onClicked drawButton $ onClickedDrawButton fileButton
|
||||
da
|
||||
_ <- onClicked saveButton $ onClickedSaveButton fileButton
|
||||
_ <- onClicked quitButton mainQuit
|
||||
|
||||
-- hotkeys
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- eventKeyName
|
||||
liftIO $ mainQuit
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"s" <- eventKeyName
|
||||
liftIO $ onClickedSaveButton fileButton
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"d" <- eventKeyName
|
||||
liftIO $ onClickedDrawButton fileButton da
|
||||
|
||||
-- draw widgets and start main loop
|
||||
widgetShowAll window
|
||||
mainGUI
|
||||
|
||||
|
||||
onClickedDrawButton :: WidgetClass widget
|
||||
=> FileChooserButton
|
||||
-> widget
|
||||
-> IO ()
|
||||
onClickedDrawButton fcb da = do
|
||||
filename <- fileChooserGetFilename fcb
|
||||
case filename of
|
||||
Just x -> do
|
||||
mesh <- readFile x
|
||||
dw <- widgetGetDrawWindow da
|
||||
let (_, r) = renderDia Cairo
|
||||
(CairoOptions "" (Width 600) SVG False)
|
||||
(diagFromString mesh)
|
||||
renderWithDrawable dw r
|
||||
Nothing -> do
|
||||
showErrorDialog "No valid Mesh file!"
|
||||
|
||||
|
||||
onClickedSaveButton :: FileChooserButton
|
||||
-> IO ()
|
||||
onClickedSaveButton fcb = do
|
||||
filename <- fileChooserGetFilename fcb
|
||||
case filename of
|
||||
Just x -> do
|
||||
mesh <- readFile x
|
||||
let (png, _) = renderDia Cairo
|
||||
(CairoOptions "out.svg" (Width 600) SVG False)
|
||||
(diagFromString mesh)
|
||||
png
|
||||
Nothing -> do
|
||||
showErrorDialog "No valid Mesh file!"
|
||||
|
||||
|
||||
showErrorDialog :: String -> IO ()
|
||||
showErrorDialog str = do
|
||||
errorDialog <- messageDialogNew Nothing
|
||||
[DialogDestroyWithParent]
|
||||
MessageError
|
||||
ButtonsClose
|
||||
str
|
||||
_ <- dialogRun errorDialog
|
||||
widgetDestroy errorDialog
|
||||
|
||||
122
Main.hs
122
Main.hs
@ -1,122 +1,4 @@
|
||||
import Control.Monad.IO.Class
|
||||
import Diagram
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Backend.Cairo
|
||||
import Diagrams.Backend.Cairo.Internal
|
||||
import Graphics.UI.Gtk
|
||||
import Graphics.UI.Gtk.Windows.MessageDialog
|
||||
import System.Directory
|
||||
|
||||
import Gtk
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
homedir <- getHomeDirectory
|
||||
|
||||
-- init gui
|
||||
_ <- initGUI
|
||||
|
||||
-- create window and widgets
|
||||
window <- windowNew
|
||||
da <- drawingAreaNew
|
||||
fileButton <- fileChooserButtonNew "Select mesh"
|
||||
FileChooserActionOpen
|
||||
drawButton <- buttonNew
|
||||
saveButton <- buttonNew
|
||||
quitButton <- buttonNew
|
||||
box1 <- vBoxNew False 0
|
||||
box2 <- hButtonBoxNew
|
||||
box3 <- hButtonBoxNew
|
||||
drawButtonLabel <- labelNew $ Just "Draw"
|
||||
saveButtonLabel <- labelNew $ Just "Save"
|
||||
quitButtonLabel <- labelNew $ Just "Quit"
|
||||
|
||||
-- containers and boxing
|
||||
containerAdd drawButton drawButtonLabel
|
||||
containerAdd saveButton saveButtonLabel
|
||||
containerAdd quitButton quitButtonLabel
|
||||
containerAdd window box1
|
||||
boxPackStart box1 da PackGrow 0
|
||||
boxPackStart box1 box2 PackNatural 0
|
||||
boxPackStart box1 box3 PackNatural 0
|
||||
boxPackStart box2 drawButton PackNatural 0
|
||||
boxPackStart box2 saveButton PackNatural 0
|
||||
boxPackStart box2 quitButton PackNatural 0
|
||||
boxPackStart box3 fileButton PackNatural 0
|
||||
|
||||
-- adjust properties
|
||||
set window [windowDefaultWidth := 600, windowDefaultHeight := 700,
|
||||
windowTitle := "Computergrafik"]
|
||||
set box2 [buttonBoxLayoutStyle := ButtonboxCenter]
|
||||
set box3 [buttonBoxLayoutStyle := ButtonboxCenter]
|
||||
_ <- windowSetTypeHint window WindowTypeHintDialog
|
||||
containerSetBorderWidth box2 10
|
||||
_ <- fileChooserSetCurrentFolder fileButton homedir
|
||||
|
||||
-- callbacks
|
||||
_ <- onDestroy window mainQuit
|
||||
_ <- onClicked drawButton $ onClickedDrawButton fileButton
|
||||
da
|
||||
_ <- onClicked saveButton $ onClickedSaveButton fileButton
|
||||
_ <- onClicked quitButton mainQuit
|
||||
|
||||
-- hotkeys
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- eventKeyName
|
||||
liftIO $ mainQuit
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"s" <- eventKeyName
|
||||
liftIO $ onClickedSaveButton fileButton
|
||||
_ <- window `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"d" <- eventKeyName
|
||||
liftIO $ onClickedDrawButton fileButton da
|
||||
|
||||
-- draw widgets and start main loop
|
||||
widgetShowAll window
|
||||
mainGUI
|
||||
|
||||
|
||||
onClickedDrawButton :: WidgetClass widget
|
||||
=> FileChooserButton
|
||||
-> widget
|
||||
-> IO ()
|
||||
onClickedDrawButton fcb da = do
|
||||
filename <- fileChooserGetFilename fcb
|
||||
case filename of
|
||||
Just x -> do
|
||||
mesh <- readFile x
|
||||
dw <- widgetGetDrawWindow da
|
||||
let (_, r) = renderDia Cairo
|
||||
(CairoOptions "" (Width 600) SVG False)
|
||||
(diagFromString mesh)
|
||||
renderWithDrawable dw r
|
||||
Nothing -> do
|
||||
showErrorDialog "No valid Mesh file!"
|
||||
|
||||
|
||||
onClickedSaveButton :: FileChooserButton
|
||||
-> IO ()
|
||||
onClickedSaveButton fcb = do
|
||||
filename <- fileChooserGetFilename fcb
|
||||
case filename of
|
||||
Just x -> do
|
||||
mesh <- readFile x
|
||||
let (png, _) = renderDia Cairo
|
||||
(CairoOptions "out.svg" (Width 600) SVG False)
|
||||
(diagFromString mesh)
|
||||
png
|
||||
Nothing -> do
|
||||
showErrorDialog "No valid Mesh file!"
|
||||
|
||||
|
||||
showErrorDialog :: String -> IO ()
|
||||
showErrorDialog str = do
|
||||
errorDialog <- messageDialogNew Nothing
|
||||
[DialogDestroyWithParent]
|
||||
MessageError
|
||||
ButtonsClose
|
||||
str
|
||||
_ <- dialogRun errorDialog
|
||||
widgetDestroy errorDialog
|
||||
main = startGUI
|
||||
|
||||
Loading…
Reference in New Issue
Block a user