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
|
