content: {-# LANGUAGE ScopedTypeVariables #-}
    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 qualified Graphics.Rendering.Cairo as C
  import Graphics.UI.Gtk
  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
    writeIORef mintervalIORef Nothing  -- the old interval may make no sense
    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
    (_ :: String) <- 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{..}
  