module ReadEvents ( 
    registerEventsFromFile, registerEventsFromTrace
  ) where

import EventTree
import State
import TestEvents
import EventDuration
import Timeline
import Traces
import Utils

import Graphics.UI.Gtk hiding (on)

import qualified GHC.RTS.Events as GHCEvents
import GHC.RTS.Events hiding (Event)

import System.IO
import Data.Array
import qualified Data.Function
import Data.IORef
import Data.List
import Text.Printf
import System.FilePath
import Control.Monad
import Data.Function
import Control.Concurrent
import Control.Exception

-------------------------------------------------------------------------------
-- The GHC.RTS.Events library returns the profile information
-- in a data-streucture which contains a list data structure
-- representing the events i.e. [GHCEvents.Event]
-- ThreadScope transforms this list into an alternative representation
-- which (for each HEC) records event *durations* which are ordered in time.
-- The durations represent the run-lengths for thread execution and
-- run-lengths for garbage colleciton. This data-structure is called
-- EventDuration. 
-- ThreadScope then transformations this data-structure into another
-- data-structure which gives a binary-tree view of the event information
-- by performing a binary split on the time domain i.e. the EventTree
-- data structure.

-- GHCEvents.Event => [EventDuration] => EventTree

-------------------------------------------------------------------------------

rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp
                -> [(DurationTree,EventTree)]
rawEventsToHECs eventList endTime
  = map (toTree . flip lookup heclists)  [0 .. maximum0 (map fst heclists)]
  where
    heclists = [ (h,events) | (Just h,events) <- eventList ]

    toTree Nothing    = (DurationTreeEmpty, EventTree 0 0 (EventTreeLeaf []))
    toTree (Just evs) = 
       ( mkDurationTree (eventsToDurations nondiscrete) endTime,
         mkEventTree discrete endTime )
       where (discrete,nondiscrete) = partition isDiscreteEvent evs

-------------------------------------------------------------------------------

-- XXX: what's this for?
maximum0 :: (Num a, Ord a) => [a] -> a
maximum0 [] = -1
maximum0 x = maximum x

-------------------------------------------------------------------------------

registerEventsFromFile :: String -> ViewerState -> IO ()
registerEventsFromFile filename state = registerEvents (Left filename) state
       
registerEventsFromTrace :: String -> ViewerState -> IO ()
registerEventsFromTrace traceName state = registerEvents (Right traceName) state
       
registerEvents :: Either FilePath String
	       -> ViewerState
	       -> IO ()

registerEvents from state@ViewerState{..} = do

  let msg = case from of
              Left filename -> filename
              Right test    -> test

--  dialog <- messageDialogNew Nothing [DialogModal] MessageInfo ButtonsCancel msg

  dialog <- dialogNew 
  dialogAddButton dialog "gtk-cancel" ResponseCancel
  widgetSetSizeRequest dialog 400 (-1)
  upper <- dialogGetUpper dialog
  hbox <- hBoxNew True 0
  label <- labelNew Nothing
  miscSetAlignment label 0 0.5
  miscSetPadding label 20 0
  labelSetMarkup label $ 
       printf "<big><b>Loading %s</b></big>"  (takeFileName msg)
  boxPackStart upper label PackGrow 10
  boxPackStart upper hbox PackNatural 10
  progress <- progressBarNew
  boxPackStart hbox progress PackGrow 20
  widgetShowAll upper
  progressBarSetText progress msg
  set dialog [ dialogHasSeparator := False ]
  timeout <- timeoutAdd (do progressBarPulse progress; return True) 50

  windowSetTitle dialog "ThreadScope"

  withBackgroundProcessing $ do

  t <- forkIO $ buildEventLog from dialog progress state
                `onException` dialogResponse dialog (ResponseUser 1)

  r <- dialogRun dialog
  case r of
    ResponseUser 1 -> return ()
    _ -> killThread t
  widgetDestroy dialog
  timeoutRemove timeout

-------------------------------------------------------------------------------

-- NB. Runs in a background thread, can call GUI functions only with
-- postGUI.
--
buildEventLog :: DialogClass dialog => Either FilePath String
              -> dialog
              -> ProgressBar -> ViewerState -> IO ()
buildEventLog from dialog progress state@ViewerState{..} =
  case from of
    Right test     -> build test (testTrace test)
    Left filename  -> do
      postGUISync $ progressBarSetText progress $ "Reading " ++ filename
      fmt <- readEventLogFromFile filename
      case fmt of
        Left  err -> hPutStr stderr err
        Right evs -> build filename evs

  where
    build name evs = do
       let 
         eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t
         eventBlockEnd e = time e

         lastTx = maximum (0 : map eventBlockEnd (events (dat evs)))
   
         groups = groupEvents (events (dat evs))
         trees = rawEventsToHECs groups lastTx

         -- sort the events by time and put them in an array
         sorted    = sortGroups groups
         n_events  = length sorted
         event_arr = listArray (0, n_events-1) sorted
         hec_count = length trees
   
         hecs = HECs {
                  hecCount         = hec_count,
                  hecTrees         = trees,
                  hecEventArray    = event_arr,
                  hecLastEventTime = lastTx
               }

         treeProgress :: ProgressBar -> Int -> (DurationTree,EventTree) -> IO ()
         treeProgress progress hec (tree1,tree2) = do
            postGUISync $ progressBarSetText progress $ 
                     printf "Building HEC %d/%d" (hec+1) hec_count
            progressBarSetFraction progress $
                     fromIntegral hec / fromIntegral hec_count
            evaluate tree1
            evaluate (eventTreeMaxDepth tree2)
            return ()

       zipWithM_ (treeProgress progress) [0..] trees

       postGUISync $ do
         windowSetTitle mainWindow ("ThreadScope - " ++ takeFileName name)
         ctx <- statusbarGetContextId statusBar "file"
         statusbarPush statusBar ctx $ 
            printf "%s (%d events, %.3fs)" name n_events
                                ((fromIntegral lastTx :: Double) * 1.0e-9)
         newHECs state hecs
         timelineParamsChanged state
         when debug $ zipWithM_ reportDurationTree [0..] (map fst trees)
         when debug $ zipWithM_ reportEventTree [0..] (map snd trees)
         writeIORef hecsIORef (Just hecs)
         writeIORef scaleIORef defaultScaleValue
         dialogResponse dialog (ResponseUser 1)

-------------------------------------------------------------------------------