1{-# LANGUAGE ScopedTypeVariables #-}
2  module GUI.Histogram (
3    HistogramView,
4    histogramViewNew,
5    histogramViewSetHECs,
6    histogramViewSetInterval,
7 ) where
8
9import Events.HECs
10import GUI.Timeline.Render (renderTraces, renderYScaleArea)
11import GUI.Timeline.Render.Constants
12import GUI.Types
13
14import qualified Graphics.Rendering.Cairo as C
15import Graphics.UI.Gtk
16import qualified GUI.GtkExtras as GtkExt
17
18import Data.IORef
19
20data HistogramView =
21  HistogramView
22  { hecsIORef            :: IORef (Maybe HECs)
23  , mintervalIORef       :: IORef (Maybe Interval)
24  , histogramDrawingArea :: DrawingArea
25  , histogramYScaleArea  :: DrawingArea
26  }
27
28histogramViewSetHECs :: HistogramView -> Maybe HECs -> IO ()
29histogramViewSetHECs HistogramView{..} mhecs = do
30  writeIORef hecsIORef mhecs
31  writeIORef mintervalIORef Nothing  -- the old interval may make no sense
32  widgetQueueDraw histogramDrawingArea
33  widgetQueueDraw histogramYScaleArea
34
35histogramViewSetInterval :: HistogramView -> Maybe Interval -> IO ()
36histogramViewSetInterval HistogramView{..} minterval = do
37  writeIORef mintervalIORef minterval
38  widgetQueueDraw histogramDrawingArea
39  widgetQueueDraw histogramYScaleArea
40
41histogramViewNew :: Builder -> IO HistogramView
42histogramViewNew builder = do
43  let getWidget cast = builderGetObject builder cast
44  histogramDrawingArea <- getWidget castToDrawingArea "histogram_drawingarea"
45  histogramYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area2"
46  timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"
47
48  -- HACK: layoutSetAttributes does not work for \mu, so let's work around
49  fd <- fontDescriptionNew
50  fontDescriptionSetSize fd 8
51  fontDescriptionSetFamily fd "sans serif"
52  widgetModifyFont histogramYScaleArea (Just fd)
53
54  (_, xh) <- widgetGetSize timelineXScaleArea
55  let xScaleAreaHeight = fromIntegral xh
56      traces = [TraceHistogram]
57      paramsHist (w, h) minterval = ViewParameters
58        { width = w
59        , height = h
60        , viewTraces = traces
61        , hadjValue = 0
62        , scaleValue = 1
63        , maxSpkValue = undefined
64        , detail = undefined
65        , bwMode = undefined
66        , labelsMode = False
67        , histogramHeight = h - histXScaleHeight
68        , minterval = minterval
69        , xScaleAreaHeight = xScaleAreaHeight
70        }
71
72  hecsIORef <- newIORef Nothing
73  mintervalIORef <- newIORef Nothing
74
75  pangoCtx <- widgetGetPangoContext histogramDrawingArea
76  style    <- get histogramDrawingArea widgetStyle
77  layout   <- layoutEmpty pangoCtx
78  (_ :: String) <- layoutSetMarkup layout $
79    "No detailed spark events in this eventlog.\n"
80    ++ "Re-run with <tt>+RTS -lf</tt> to generate them."
81
82  -- Program the callback for the capability drawingArea
83  on histogramDrawingArea exposeEvent $
84     C.liftIO $ do
85       maybeEventArray <- readIORef hecsIORef
86       win <- widgetGetDrawWindow histogramDrawingArea
87       (w, windowHeight) <- widgetGetSize histogramDrawingArea
88       case maybeEventArray of
89         Nothing -> return False
90         Just hecs
91           | null (durHistogram hecs) -> do
92               GtkExt.stylePaintLayout
93                 style win
94                 StateNormal True
95                 (Rectangle 0 0 w windowHeight)
96                 histogramDrawingArea ""
97                 4 20
98                 layout
99               return True
100           | otherwise -> do
101               minterval <- readIORef mintervalIORef
102               if windowHeight < 80
103                 then return False
104                 else do
105                   let size = (w, windowHeight - firstTraceY)
106                       params = paramsHist size minterval
107                       rect = Rectangle 0 0 w (snd size)
108                   renderWithDrawable win $
109                     renderTraces params hecs rect
110                   return True
111
112  -- Redrawing histogramYScaleArea
113  histogramYScaleArea `onExpose` \_ -> do
114    maybeEventArray <- readIORef hecsIORef
115    case maybeEventArray of
116      Nothing -> return False
117      Just hecs
118        | null (durHistogram hecs) -> return False
119        | otherwise -> do
120            win <- widgetGetDrawWindow histogramYScaleArea
121            minterval <- readIORef mintervalIORef
122            (_, windowHeight) <- widgetGetSize histogramYScaleArea
123            if windowHeight < 80
124              then return False
125              else do
126                let size = (undefined, windowHeight - firstTraceY)
127                    params = paramsHist size minterval
128                renderWithDrawable win $
129                  renderYScaleArea params hecs histogramYScaleArea
130                return True
131
132  return HistogramView{..}
133