Page.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}

module Gui.Page where

import Control.Monad
import qualified Data.Text as T
import Data.IORef

import GI.Gtk hiding (main)

import Gui
import Gui.TreeWidget
import Gui.Utils

import Types
import Operations

data Page = Page {
    pageWidget :: Box
  , pageSearchState :: IORef (Int, [TreePath])
  }

type ShowTree = T.Text -> CostCentreData -> IO ()

mkContextMenu :: TreeView -> CostCentreData -> ShowTree -> IO Menu
mkContextMenu tree ccd showTree = do
  menu <- menuNew

--   mkMenuItem menu "Test" $ do
--     withSelected tree $ \store selected -> do
--       Just name <- getItem store selected nameColumn
--       print (name :: T.Text)
--       Just mod <- getItem store selected moduleColumn
--       Just src <- getItem store selected sourceColumn
--       let subtrees = ccdFind mod src name ccd
--       forM_ subtrees $ \child -> do
--         let parent = case ccdParent child of
--                        Nothing -> "no parent"
--                        Just parent -> T.pack (ccdRecordIds parent) <> ": " <> ccdLabel parent <> " = " <> T.pack (show $ ccdTimeInherited parent)
--         print $ T.pack (ccdRecordIds child) <> ": " <> ccdLabel child <> " = " <> T.pack (show $ ccdTimeInherited child) <> " => " <> parent

  mkMenuItem menu "Narrow view to this item" $ do
    withSelected tree $ \store selected -> do
      path <- getTruePath store selected
      Just idxs <- treePathGetIndices path
      case ccdByPath idxs ccd of
        Nothing -> return ()
        Just child -> do
          let label = ccdLabel child
          showTree ("Narrowed view: " <> label) child

  mkMenuItem menu "Group all outgoing calls" $
    withSelected tree $ \store selected -> do
      Just name <- getItem store selected nameColumn
      Just mod <- getItem store selected moduleColumn
      Just src <- getItem store selected sourceColumn
      let subtrees = ccdFind mod src name ccd
          result = ccdSum subtrees
      showTree ("Calls of " <> name) result

  mkMenuItem menu "Group all incoming calls" $
    withSelected tree $ \store selected -> do
      Just name <- getItem store selected nameColumn
      Just mod <- getItem store selected moduleColumn
      Just src <- getItem store selected sourceColumn
      let subtrees = ccdFindIncoming mod src name ccd
          result = ccdSum subtrees
      showTree ("Calls to " <> name) result
      
  return menu

mkPage :: Statusbar -> T.Text -> CostCentreData -> ShowTree -> IO Page
mkPage status label ccd showTree = do
  vbox <- boxNew OrientationVertical 0
  searchHbox <- boxNew OrientationHorizontal 0
  filterBox <- boxNew OrientationHorizontal 0

  entry <- searchEntryNew
  boxPackStart searchHbox entry True True 0
  searchButton <- buttonNewWithLabel "Search"
  searchNextButton <- buttonNewWithLabel "Next"
  searchMethodCombo <- mkComboBox [
                           (Contains, "Contains")
                         , (Exact, "Exact")
                         , (Regexp, "Reg.Exp")
                       ]

  boxPackStart searchHbox searchButton False False 0
  boxPackStart searchHbox searchNextButton False False 0
  boxPackStart searchHbox searchMethodCombo False False 0
  boxPackStart vbox searchHbox False False 0

  on entry #activate $ buttonClicked searchButton

  let addFilterPercent name = do
        lbl <- labelNew (Just name)
        spin <- spinButtonNewWithRange 0 100 1
        spinButtonSetDigits spin 2
        boxPackStart filterBox lbl False False 10
        boxPackStart filterBox spin True True 0
        return spin

  let addFilterNumber name = do
        lbl <- labelNew (Just name)
        spin <- spinButtonNewWithRange 0 (1e38) 1
        spinButtonSetDigits spin 0
        boxPackStart filterBox lbl False False 10
        boxPackStart filterBox spin True True 0
        return spin

  let addFilterText name = do
        lbl <- labelNew (Just name)
        entry <- entryNew
        boxPackStart filterBox lbl False False 10
        boxPackStart filterBox entry True True 0
        return entry

  fltrEntries <- addFilterNumber "Entries:"
  fltrTimeIndividual <- addFilterPercent "Time Individual:"
  fltrAllocIndividual <- addFilterPercent "Alloc Individual:"
  fltrTimeInherited <- addFilterPercent "Time Inherited:"
  fltrAllocInherited <- addFilterPercent "Alloc Inherited:"
  fltrModule <- addFilterText "Module:"
  fltrSource <- addFilterText "Source:"

  filterButton <- buttonNewWithLabel "Filter"

  boxPackStart filterBox filterButton False False 0
  boxPackStart vbox filterBox False False 0

  tree <- mkTreeView treeWidgetConfig ccd
  treeViewSetSearchColumn tree 1
  treeViewSetEnableSearch tree False
  let noAdjustment = Nothing :: Maybe Adjustment
  scroll <- scrolledWindowNew noAdjustment noAdjustment
  containerAdd scroll tree
  boxPackStart vbox scroll True True 10

  statusContext <- statusbarGetContextId status label

  searchResults <- newIORef (0, [])

  let message text =
        void $ statusbarPush status statusContext (T.pack text)

  on searchButton #clicked $ do
    text <- entryGetText entry
    unless (T.null text) $ do
      Just methodId <- comboBoxGetActiveId searchMethodCombo
      let method = read $ T.unpack methodId
      results <- treeSearch tree method text
      if null results
        then message "Not found."
        else do
          message $ "Found: " ++ show (length results)
          writeIORef searchResults (0, results)
          Just store <- treeViewGetModel tree
          let path = head results
          treeViewExpandToPath tree path
          treeViewSetCursor tree path (Nothing :: Maybe TreeViewColumn) False

  on searchNextButton #clicked $ do
    (prevIndex, results) <- readIORef searchResults
    if null results
      then message "Not found."
      else do
        let n = length results
            index = (prevIndex + 1) `mod` n
            path = results !! index
        message $ "Found: " ++ show index ++ "/" ++ show n
        writeIORef searchResults (index, results)
        treeViewExpandToPath tree path
        treeViewSetCursor tree path (Nothing :: Maybe TreeViewColumn) False

  on filterButton #clicked $ do
    entries <- spinButtonGetValueAsInt fltrEntries
    timeIndividual <- spinButtonGetValue fltrTimeIndividual
    allocIndividual <- spinButtonGetValue fltrAllocIndividual
    timeInherited <- spinButtonGetValue fltrTimeInherited
    allocInherited <- spinButtonGetValue fltrAllocInherited
    mod <- entryGetText fltrModule
    src <- entryGetText fltrSource

    let params = FilterParams {
          fpEntries = fromIntegral entries
        , fpTimeIndividual = timeIndividual
        , fpAllocIndividual = allocIndividual
        , fpTimeInherited = timeInherited
        , fpAllocInherited = allocInherited
        , fpModule = mod
        , fpSource = src
      }
    let ccd' = filterCcdRecursive (checkFilter params) ccd
    showTree "Filtered" ccd'

  on tree #buttonPressEvent $ \ev -> do
    button <- get ev #button
    when (button == 3) $ do
      menu <- mkContextMenu tree ccd showTree
      menuPopupAtPointer menu Nothing
    return False

  return $ Page vbox searchResults