1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162
|
{-# LANGUAGE TemplateHaskell #-}
module GUI.Dialogs where
import GUI.DataFiles (loadLogo)
import Paths_threadscope (version)
import Graphics.UI.Gtk
import Data.Version (showVersion)
import System.FilePath
-------------------------------------------------------------------------------
aboutDialog :: WindowClass window => window -> IO ()
aboutDialog parent
= do dialog <- aboutDialogNew
logo <- $loadLogo
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 := 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
|