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
|
module GUI.Histogram (
HistogramView,
histogramViewNew,
histogramViewSetHECs,
histogramViewSetInterval,
) where
import Events.HECs
import GUI.Timeline.Render (renderTraces, renderYScaleArea)
import GUI.Timeline.Render.Constants
import GUI.Types
import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as C
import qualified GUI.GtkExtras as GtkExt
import Data.IORef
data HistogramView =
HistogramView
{ hecsIORef :: IORef (Maybe HECs)
, mintervalIORef :: IORef (Maybe Interval)
, histogramDrawingArea :: DrawingArea
, histogramYScaleArea :: DrawingArea
}
histogramViewSetHECs :: HistogramView -> Maybe HECs -> IO ()
histogramViewSetHECs HistogramView{..} mhecs = do
writeIORef hecsIORef mhecs
widgetQueueDraw histogramDrawingArea
widgetQueueDraw histogramYScaleArea
histogramViewSetInterval :: HistogramView -> Maybe Interval -> IO ()
histogramViewSetInterval HistogramView{..} minterval = do
writeIORef mintervalIORef minterval
widgetQueueDraw histogramDrawingArea
widgetQueueDraw histogramYScaleArea
histogramViewNew :: Builder -> IO HistogramView
histogramViewNew builder = do
let getWidget cast = builderGetObject builder cast
histogramDrawingArea <- getWidget castToDrawingArea "histogram_drawingarea"
histogramYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area2"
timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"
-- HACK: layoutSetAttributes does not work for \mu, so let's work around
fd <- fontDescriptionNew
fontDescriptionSetSize fd 8
fontDescriptionSetFamily fd "sans serif"
widgetModifyFont histogramYScaleArea (Just fd)
(_, xh) <- widgetGetSize timelineXScaleArea
let xScaleAreaHeight = fromIntegral xh
traces = [TraceHistogram]
paramsHist (w, h) minterval = ViewParameters
{ width = w
, height = h
, viewTraces = traces
, hadjValue = 0
, scaleValue = 1
, maxSpkValue = undefined
, detail = undefined
, bwMode = undefined
, labelsMode = False
, histogramHeight = h - histXScaleHeight
, minterval = minterval
, xScaleAreaHeight = xScaleAreaHeight
}
hecsIORef <- newIORef Nothing
mintervalIORef <- newIORef Nothing
pangoCtx <- widgetGetPangoContext histogramDrawingArea
style <- get histogramDrawingArea widgetStyle
layout <- layoutEmpty pangoCtx
layoutSetMarkup layout $ "No detailed spark events in this eventlog.\n"
++ "Re-run with <tt>+RTS -lf</tt> to generate them."
-- Program the callback for the capability drawingArea
on histogramDrawingArea exposeEvent $
C.liftIO $ do
maybeEventArray <- readIORef hecsIORef
win <- widgetGetDrawWindow histogramDrawingArea
(w, windowHeight) <- widgetGetSize histogramDrawingArea
case maybeEventArray of
Nothing -> return False
Just hecs
| null (durHistogram hecs) -> do
GtkExt.stylePaintLayout
style win
StateNormal True
(Rectangle 0 0 w windowHeight)
histogramDrawingArea ""
4 20
layout
return True
| otherwise -> do
minterval <- readIORef mintervalIORef
if windowHeight < 80
then return False
else do
let size = (w, windowHeight - firstTraceY)
params = paramsHist size minterval
rect = Rectangle 0 0 w (snd size)
renderWithDrawable win $
renderTraces params hecs rect
return True
-- Redrawing histogramYScaleArea
histogramYScaleArea `onExpose` \_ -> do
maybeEventArray <- readIORef hecsIORef
case maybeEventArray of
Nothing -> return False
Just hecs
| null (durHistogram hecs) -> return False
| otherwise -> do
win <- widgetGetDrawWindow histogramYScaleArea
minterval <- readIORef mintervalIORef
(_, windowHeight) <- widgetGetSize histogramYScaleArea
if windowHeight < 80
then return False
else do
let size = (undefined, windowHeight - firstTraceY)
params = paramsHist size minterval
renderWithDrawable win $
renderYScaleArea params hecs histogramYScaleArea
return True
return HistogramView{..}
|
