content: module GUI.Timeline.HEC (
      renderHEC,
      renderInstantHEC,
    ) where
  
  import GUI.Timeline.Render.Constants
  
  import Events.EventTree
  import Events.EventDuration
  import GUI.Types
  import GUI.Timeline.CairoDrawing
  import GUI.ViewerColours
  
  import Graphics.Rendering.Cairo
  
  import qualified GHC.RTS.Events as GHC
  import GHC.RTS.Events hiding (Event, GCWork, GCIdle)
  
  import qualified Data.IntMap as IM
  import Data.Maybe
  import Control.Monad
  
  renderHEC :: ViewParameters -> Timestamp -> Timestamp
            -> IM.IntMap String -> (DurationTree,EventTree)
            -> Render ()
  renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do
    renderDurations params start end dtree
    when (scaleValue < detailThreshold) $
       case etree of
         EventTree ltime etime tree -> do
           renderEvents params ltime etime start end (fromIntegral detail)
             perfNames tree
           return ()
  
  renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp
                   -> IM.IntMap String -> EventTree
                   -> Render ()
  renderInstantHEC params@ViewParameters{..} start end
                   perfNames (EventTree ltime etime tree) = do
    let instantDetail = 1
    renderEvents params ltime etime start end instantDetail perfNames tree
    return ()
  
  detailThreshold :: Double
  detailThreshold = 3
  
  -------------------------------------------------------------------------------
  -- draws the trace for a single HEC
  
  renderDurations :: ViewParameters
                  -> Timestamp -> Timestamp -> DurationTree
                  -> Render ()
  
  renderDurations _ _ _ DurationTreeEmpty = return ()
  
  renderDurations params@ViewParameters{..} startPos endPos (DurationTreeLeaf e)
    | inView startPos endPos e = drawDuration params e
    | otherwise                = return ()
  
  renderDurations params@ViewParameters{..} !startPos !endPos
          (DurationSplit s splitTime e lhs rhs runAv gcAv)
    | startPos < splitTime && endPos >= splitTime &&
            (fromIntegral (e - s) / scaleValue) <= fromIntegral detail
    = -- View spans both left and right sub-tree.
      -- trace (printf "renderDurations (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $
      drawAverageDuration params s e runAv gcAv
  
    | otherwise
    = -- trace (printf "renderDurations: start:%d end:%d s:%d e:%d" startPos endPos s e) $
      do when (startPos < splitTime) $
           renderDurations params startPos endPos lhs
         when (endPos >= splitTime) $
           renderDurations params startPos endPos rhs
  
  -------------------------------------------------------------------------------
  
  renderEvents :: ViewParameters
               -> Timestamp -- start time of this tree node
               -> Timestamp -- end   time of this tree node
               -> Timestamp -> Timestamp -> Double
               -> IM.IntMap String -> EventNode
               -> Render Bool
  
  renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth
               perfNames (EventTreeLeaf es)
    = let within = [ e | e <- es, let t = time e, t >= startPos && t < endPos ]
          untilTrue _ [] = return False
          untilTrue f (x : xs) = do
            b <- f x
            if b then return b else untilTrue f xs
      in untilTrue (drawEvent params ewidth perfNames) within
  
  renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth
          perfNames (EventTreeOne ev)
    | t >= startPos && t < endPos = drawEvent params ewidth perfNames ev
    | otherwise = return False
    where t = time ev
  
  renderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth
          perfNames (EventSplit splitTime lhs rhs)
    | startPos < splitTime && endPos >= splitTime &&
          (fromIntegral (e - s) / scaleValue) <= ewidth
    = do drawnLhs <-
             renderEvents params s splitTime startPos endPos ewidth perfNames lhs
         if not drawnLhs
           then
             renderEvents params splitTime e startPos endPos ewidth perfNames rhs
           else return True
    | otherwise
    = do drawnLhs <-
           if startPos < splitTime
           then
             renderEvents params s splitTime startPos endPos ewidth perfNames lhs
           else return False
         drawnRhs <-
           if endPos >= splitTime
           then
             renderEvents params splitTime e startPos endPos ewidth perfNames rhs
           else return False
         return $ drawnLhs || drawnRhs
  
  -------------------------------------------------------------------------------
  -- An event is in view if it is not outside the view.
  
  inView :: Timestamp -> Timestamp -> EventDuration -> Bool
  inView viewStart viewEnd event =
    not (eStart > viewEnd || eEnd <= viewStart)
   where
    eStart = startTimeOf event
    eEnd   = endTimeOf event
  
  -------------------------------------------------------------------------------
  
  drawAverageDuration :: ViewParameters
                      -> Timestamp -> Timestamp -> Timestamp -> Timestamp
                      -> Render ()
  drawAverageDuration ViewParameters{..} startTime endTime runAv gcAv = do
    setSourceRGBAhex (if not bwMode then runningColour else black) 1.0
    when (runAv > 0) $
      draw_rectangle startTime hecBarOff         -- x, y
                     (endTime - startTime)       -- w
                      hecBarHeight
    setSourceRGBAhex black 1.0
    --move_to (oxs + startTime, 0)
    --relMoveTo (4/scaleValue) 13
    --unscaledText scaleValue (show nrEvents)
    setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio
    draw_rectangle startTime      -- x
                   (hecBarOff+hecBarHeight)      -- y
                   (endTime - startTime)         -- w
                   (hecBarHeight `div` 2)        -- h
  
   where
    duration = endTime - startTime
  --    runRatio :: Double
  --    runRatio = (fromIntegral runAv) / (fromIntegral duration)
    gcRatio :: Double
    gcRatio = (fromIntegral gcAv) / (fromIntegral duration)
  
  -------------------------------------------------------------------------------
  
  unscaledText :: String -> Render ()
  unscaledText text
    = do m <- getMatrix
         identityMatrix
         showText text
         setMatrix m
  
  -------------------------------------------------------------------------------
  
  textWidth :: Double -> String -> Render TextExtents
  textWidth _scaleValue text
    = do m <- getMatrix
         identityMatrix
         tExtent <- textExtents text
         setMatrix m
         return tExtent
  
  -------------------------------------------------------------------------------
  
  drawDuration :: ViewParameters -> EventDuration -> Render ()
  drawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do
    setSourceRGBAhex (if not bwMode then runningColour else black) 1.0
    setLineWidth (1/scaleValue)
    draw_rectangle_opt False
                   startTime                  -- x
                   hecBarOff                  -- y
                   (endTime - startTime)      -- w
                   hecBarHeight               -- h
    -- Optionally label the bar with the threadID if there is room
    tExtent <- textWidth scaleValue tStr
    let tw = textExtentsWidth  tExtent
        th = textExtentsHeight tExtent
    when (tw + 6 < fromIntegral rectWidth) $ do
      setSourceRGBAhex labelTextColour 1.0
      move_to (fromIntegral startTime + truncate (4*scaleValue),
               hecBarOff + (hecBarHeight + round th) `quot` 2)
      unscaledText tStr
  
     -- Optionally write the reason for the thread being stopped
     -- depending on the zoom value
    labelAt labelsMode endTime $
      show t ++ " " ++ showThreadStopStatus s
   where
    rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels
    tStr = show t
  
  drawDuration ViewParameters{..} (GCStart startTime endTime)
    = gcBar (if bwMode then black else gcStartColour) startTime endTime
  
  drawDuration ViewParameters{..} (GCWork startTime endTime)
    = gcBar (if bwMode then black else gcWorkColour) startTime endTime
  
  drawDuration ViewParameters{..} (GCIdle startTime endTime)
    = gcBar (if bwMode then black else gcIdleColour) startTime endTime
  
  drawDuration ViewParameters{..} (GCEnd startTime endTime)
    = gcBar (if bwMode then black else gcEndColour) startTime endTime
  
  drawDuration ViewParameters{..} (TXStart startTime endTime)
    = txBar (if bwMode then black else txStartColour) startTime endTime
  
  txBar :: Color -> Timestamp -> Timestamp -> Render ()
  txBar col !startTime !endTime = do
    setSourceRGBAhex col 1.0
    draw_rectangle_opt False
                       startTime                      -- x
                       (hecBarOff+hecBarHeight)       -- y
                       (endTime - startTime)          -- w
                       (hecBarHeight `div` 2)         -- h
  
  gcBar :: Color -> Timestamp -> Timestamp -> Render ()
  gcBar col !startTime !endTime = do
    setSourceRGBAhex col 1.0
    draw_rectangle_opt False
                       startTime                      -- x
                       (hecBarOff+hecBarHeight)       -- y
                       (endTime - startTime)          -- w
                       (hecBarHeight `div` 2)         -- h
  
  labelAt :: Bool -> Timestamp -> String -> Render ()
  labelAt labelsMode t str
    | not labelsMode = return ()
    | otherwise = do
         setSourceRGB 0.0 0.0 0.0
         move_to (t, hecBarOff+hecBarHeight+12)
         save
         identityMatrix
         rotate (pi/4)
         showText str
         restore
  
  drawEvent :: ViewParameters -> Double -> IM.IntMap String -> GHC.Event
            -> Render Bool
  drawEvent params@ViewParameters{..} ewidth perfNames event =
    let renderI = renderInstantEvent params perfNames event ewidth
    in case spec event of
      VProcStartIdle -> renderI red
  {-
      CreateThread{}  -> renderI createThreadColour
      RequestSeqGC{}  -> renderI seqGCReqColour
      RequestParGC{}  -> renderI parGCReqColour
      MigrateThread{} -> renderI migrateThreadColour
      WakeupThread{}  -> renderI threadWakeupColour
      Shutdown{}      -> renderI shutdownColour
  
      SparkCreate{}   -> renderI createdConvertedColour
      SparkDud{}      -> renderI fizzledDudsColour
      SparkOverflow{} -> renderI overflowedColour
      SparkRun{}      -> renderI createdConvertedColour
      SparkSteal{}    -> renderI createdConvertedColour
      SparkFizzle{}   -> renderI fizzledDudsColour
      SparkGC{}       -> renderI gcColour
  
  --BEGIN STM
      StartTX{}       -> renderI seqGCReqColour
      StartTXWInfo{} -> renderI seqGCReqColour
      CommitTX{}      -> renderI userMessageColour
      EagerPartialAbort{} -> renderI fizzledDudsColour
      CommitTimePartialAbort{} -> renderI fizzledDudsColour
      EagerFullAbort{} -> renderI shutdownColour
      CommitTimeFullAbort{} -> renderI shutdownColour
      FastForward{} -> renderI bookmarkColour
      BeginCommit{} -> renderI parGCReqColour
      TSExtension{} -> renderI seqGCReqColour
  --END STM
  
      MsgSend{} -> renderI seqGCReqColour
  
      RememberObj{} -> renderI parGCReqColour
  
      MajorGC{} -> renderI shutdownColour
      GlobalGC{} -> renderI threadWakeupColour
  
      UserMessage{}   -> renderI userMessageColour
  
      PerfCounter{}    -> renderI createdConvertedColour
      PerfTracepoint{} -> renderI shutdownColour
      PerfName{}       -> return False
  -}
      RunThread{}  -> return False
      StopThread{} -> return False
      StartGC{}    -> return False
  
      _ -> return False
  
  renderInstantEvent :: ViewParameters -> IM.IntMap String -> GHC.Event
                     -> Double -> Color
                     -> Render Bool
  renderInstantEvent ViewParameters{..} perfNames event ewidth color = do
    setSourceRGBAhex color 1.0
    setLineWidth (ewidth * scaleValue)
    let t = time event
    draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)
    let numToLabel PerfCounter{perfNum, period} | period == 0 =
          IM.lookup (fromIntegral perfNum) perfNames
        numToLabel PerfCounter{perfNum, period} =
          fmap (++ " <" ++ show (period + 1) ++ " times>") $
            IM.lookup (fromIntegral perfNum) perfNames
        numToLabel PerfTracepoint{perfNum} =
          fmap ("tracepoint: " ++) $ IM.lookup (fromIntegral perfNum) perfNames
        numToLabel _ = Nothing
        showLabel espec = fromMaybe (showEventInfo espec) (numToLabel espec)
    labelAt labelsMode t $ showLabel (spec event)
    return True
  
  -------------------------------------------------------------------------------
  