module GUI.Dialogs where
import Paths_threadscope (getDataFileName, version)
import Graphics.UI.Gtk
import Data.Version (showVersion)
import System.FilePath
-------------------------------------------------------------------------------
aboutDialog :: WindowClass window => window -> IO ()
aboutDialog parent
= do dialog <- aboutDialogNew
logoPath <- getDataFileName "threadscope.png"
logo <- pixbufNewFromFile logoPath
set dialog [
aboutDialogName := "ThreadScope",
aboutDialogVersion := showVersion version,
aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.",
aboutDialogComments := "A GHC eventlog profile viewer",
aboutDialogAuthors := ["Donnie Jones <donnie@darthik.com>",
"Simon Marlow <simonm@microsoft.com>",
"Satnam Singh <s.singh@ieee.org>",
"Duncan Coutts <duncan@well-typed.com>",
"Mikolaj Konarski <mikolaj@well-typed.com>",
"Nicolas Wu <nick@well-typed.com>",
"Eric Kow <eric@well-typed.com>"],
aboutDialogLogo := Just logo,
aboutDialogWebsite := "http://www.haskell.org/haskellwiki/ThreadScope",
windowTransientFor := toWindow parent
]
onResponse dialog $ \_ -> widgetDestroy dialog
widgetShow dialog
-------------------------------------------------------------------------------
openFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO ()
openFileDialog parent open
= do dialog <- fileChooserDialogNew
(Just "Open Profile...")
(Just (toWindow parent))
FileChooserActionOpen
[("gtk-cancel", ResponseCancel)
,("gtk-open", ResponseAccept)]
set dialog [
windowModal := True
]
eventlogfiles <- fileFilterNew
fileFilterSetName eventlogfiles "GHC eventlog files (*.eventlog)"
fileFilterAddPattern eventlogfiles "*.eventlog"
fileChooserAddFilter dialog eventlogfiles
allfiles <- fileFilterNew
fileFilterSetName allfiles "All files"
fileFilterAddPattern allfiles "*"
fileChooserAddFilter dialog allfiles
onResponse dialog $ \response -> do
case response of
ResponseAccept -> do
mfile <- fileChooserGetFilename dialog
case mfile of
Just file -> open file
Nothing -> return ()
_ -> return ()
widgetDestroy dialog
widgetShowAll dialog
-------------------------------------------------------------------------------
data FileExportFormat = FormatPDF | FormatPNG
exportFileDialog :: WindowClass window => window
-> FilePath
-> (FilePath -> FileExportFormat -> IO ())
-> IO ()
exportFileDialog parent oldfile save = do
dialog <- fileChooserDialogNew
(Just "Save timeline image...")
(Just (toWindow parent))
FileChooserActionSave
[("gtk-cancel", ResponseCancel)
,("gtk-save", ResponseAccept)]
set dialog [
fileChooserDoOverwriteConfirmation := True,
windowModal := True
]
let (olddir, oldfilename) = splitFileName oldfile
fileChooserSetCurrentName dialog (replaceExtension oldfilename "png")
fileChooserSetCurrentFolder dialog olddir
pngFiles <- fileFilterNew
fileFilterSetName pngFiles "PNG bitmap files"
fileFilterAddPattern pngFiles "*.png"
fileChooserAddFilter dialog pngFiles
pdfFiles <- fileFilterNew
fileFilterSetName pdfFiles "PDF files"
fileFilterAddPattern pdfFiles "*.pdf"
fileChooserAddFilter dialog pdfFiles
onResponse dialog $ \response ->
case response of
ResponseAccept -> do
mfile <- fileChooserGetFilename dialog
case mfile of
Just file
| takeExtension file == ".pdf" -> do
save file FormatPDF
widgetDestroy dialog
| takeExtension file == ".png" -> do
save file FormatPNG
widgetDestroy dialog
| otherwise ->
formatError dialog
Nothing -> widgetDestroy dialog
_ -> widgetDestroy dialog
widgetShowAll dialog
where
formatError dialog = do
msg <- messageDialogNew (Just (toWindow dialog))
[DialogModal, DialogDestroyWithParent]
MessageError ButtonsClose
"The file format is unknown or unsupported"
set msg [
messageDialogSecondaryText := Just $
"The PNG and PDF formats are supported. "
++ "Please use a file extension of '.png' or '.pdf'."
]
dialogRun msg
widgetDestroy msg
-------------------------------------------------------------------------------
errorMessageDialog :: WindowClass window => window -> String -> String -> IO ()
errorMessageDialog parent headline explanation = do
dialog <- messageDialogNew (Just (toWindow parent))
[] MessageError ButtonsNone ""
set dialog
[ windowModal := True
, windowTransientFor := toWindow parent
, messageDialogText := Just headline
, messageDialogSecondaryText := Just explanation
, windowResizable := True
]
dialogAddButton dialog "Close" ResponseClose
dialogSetDefaultResponse dialog ResponseClose
onResponse dialog $ \_-> widgetDestroy dialog
widgetShowAll dialog