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