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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
{-# LANGUAGE TemplateHaskell #-}
module GUI.MainWindow (
MainWindow,
mainWindowNew,
MainWindowActions(..),
setFileLoaded,
setStatusMessage,
sidebarSetVisibility,
eventsSetVisibility,
) where
import Graphics.UI.Gtk as Gtk
import qualified System.Glib.GObject as Glib
import GUI.DataFiles (loadLogo)
-------------------------------------------------------------------------------
data MainWindow = MainWindow {
mainWindow :: Window,
sidebarBox,
eventsBox :: Widget,
statusBar :: Statusbar,
statusBarCxt :: ContextId
}
instance Glib.GObjectClass MainWindow where
toGObject = toGObject . mainWindow
unsafeCastGObject = error "cannot downcast to MainView type"
instance Gtk.ObjectClass MainWindow
instance Gtk.WidgetClass MainWindow
instance Gtk.ContainerClass MainWindow
instance Gtk.BinClass MainWindow
instance Gtk.WindowClass MainWindow
data MainWindowActions = MainWindowActions {
-- Menu actions
mainWinOpen :: IO (),
mainWinExport :: IO (),
mainWinQuit :: IO (),
mainWinViewSidebar :: Bool -> IO (),
mainWinViewEvents :: Bool -> IO (),
mainWinViewBW :: Bool -> IO (),
mainWinViewReload :: IO (),
mainWinWebsite :: IO (),
mainWinTutorial :: IO (),
mainWinAbout :: IO (),
-- Toolbar actions
mainWinJumpStart :: IO (),
mainWinJumpEnd :: IO (),
mainWinJumpCursor :: IO (),
mainWinJumpZoomIn :: IO (),
mainWinJumpZoomOut :: IO (),
mainWinJumpZoomFit :: IO (),
mainWinScrollLeft :: IO (),
mainWinScrollRight :: IO (),
mainWinDisplayLabels :: Bool -> IO ()
}
-------------------------------------------------------------------------------
setFileLoaded :: MainWindow -> Maybe FilePath -> IO ()
setFileLoaded mainWin Nothing =
set (mainWindow mainWin) [
windowTitle := "ThreadScope"
]
setFileLoaded mainWin (Just file) =
set (mainWindow mainWin) [
windowTitle := file ++ " - ThreadScope"
]
setStatusMessage :: MainWindow -> String -> IO ()
setStatusMessage mainWin msg = do
statusbarPop (statusBar mainWin) (statusBarCxt mainWin)
statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg)
return ()
sidebarSetVisibility :: MainWindow -> Bool -> IO ()
sidebarSetVisibility mainWin visible =
set (sidebarBox mainWin) [ widgetVisible := visible ]
eventsSetVisibility :: MainWindow -> Bool -> IO ()
eventsSetVisibility mainWin visible =
set (eventsBox mainWin) [ widgetVisible := visible ]
-------------------------------------------------------------------------------
mainWindowNew :: Builder -> MainWindowActions -> IO MainWindow
mainWindowNew builder actions = do
let getWidget cast name = builderGetObject builder cast name
mainWindow <- getWidget castToWindow "main_window"
statusBar <- getWidget castToStatusbar "statusbar"
sidebarBox <- getWidget castToWidget "sidebar"
eventsBox <- getWidget castToWidget "eventsbox"
bwToggle <- getWidget castToCheckMenuItem "black_and_white"
labModeToggle <- getWidget castToCheckMenuItem "view_labels_mode"
sidebarToggle <- getWidget castToCheckMenuItem "view_sidebar"
eventsToggle <- getWidget castToCheckMenuItem "view_events"
openMenuItem <- getWidget castToMenuItem "openMenuItem"
exportMenuItem <- getWidget castToMenuItem "exportMenuItem"
reloadMenuItem <- getWidget castToMenuItem "view_reload"
quitMenuItem <- getWidget castToMenuItem "quitMenuItem"
websiteMenuItem <- getWidget castToMenuItem "websiteMenuItem"
tutorialMenuItem <- getWidget castToMenuItem "tutorialMenuItem"
aboutMenuItem <- getWidget castToMenuItem "aboutMenuItem"
firstMenuItem <- getWidget castToMenuItem "move_first"
centreMenuItem <- getWidget castToMenuItem "move_centre"
lastMenuItem <- getWidget castToMenuItem "move_last"
zoomInMenuItem <- getWidget castToMenuItem "move_zoomin"
zoomOutMenuItem <- getWidget castToMenuItem "move_zoomout"
zoomFitMenuItem <- getWidget castToMenuItem "move_zoomfit"
openButton <- getWidget castToToolButton "cpus_open"
firstButton <- getWidget castToToolButton "cpus_first"
centreButton <- getWidget castToToolButton "cpus_centre"
lastButton <- getWidget castToToolButton "cpus_last"
zoomInButton <- getWidget castToToolButton "cpus_zoomin"
zoomOutButton <- getWidget castToToolButton "cpus_zoomout"
zoomFitButton <- getWidget castToToolButton "cpus_zoomfit"
------------------------------------------------------------------------
-- Show everything
widgetShowAll mainWindow
------------------------------------------------------------------------
logo <- $loadLogo
set mainWindow [ windowIcon := logo ]
------------------------------------------------------------------------
-- Status bar functionality
statusBarCxt <- statusbarGetContextId statusBar "file"
statusbarPush statusBar statusBarCxt "No eventlog loaded."
------------------------------------------------------------------------
-- Bind all the events
-- Menus
on openMenuItem menuItemActivate $ mainWinOpen actions
on exportMenuItem menuItemActivate $ mainWinExport actions
on quitMenuItem menuItemActivate $ mainWinQuit actions
on mainWindow objectDestroy $ mainWinQuit actions
on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle
>>= mainWinViewSidebar actions
on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle
>>= mainWinViewEvents actions
on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle
>>= mainWinViewBW actions
on labModeToggle checkMenuItemToggled $ checkMenuItemGetActive labModeToggle
>>= mainWinDisplayLabels actions
on reloadMenuItem menuItemActivate $ mainWinViewReload actions
on websiteMenuItem menuItemActivate $ mainWinWebsite actions
on tutorialMenuItem menuItemActivate $ mainWinTutorial actions
on aboutMenuItem menuItemActivate $ mainWinAbout actions
on firstMenuItem menuItemActivate $ mainWinJumpStart actions
on centreMenuItem menuItemActivate $ mainWinJumpCursor actions
on lastMenuItem menuItemActivate $ mainWinJumpEnd actions
on zoomInMenuItem menuItemActivate $ mainWinJumpZoomIn actions
on zoomOutMenuItem menuItemActivate $ mainWinJumpZoomOut actions
on zoomFitMenuItem menuItemActivate $ mainWinJumpZoomFit actions
-- Toolbar
onToolButtonClicked openButton $ mainWinOpen actions
onToolButtonClicked firstButton $ mainWinJumpStart actions
onToolButtonClicked centreButton $ mainWinJumpCursor actions
onToolButtonClicked lastButton $ mainWinJumpEnd actions
onToolButtonClicked zoomInButton $ mainWinJumpZoomIn actions
onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions
onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions
return MainWindow {..}
|
