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 ", "Simon Marlow ", "Satnam Singh ", "Duncan Coutts ", "Mikolaj Konarski ", "Nicolas Wu ", "Eric Kow "], 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