BreakPointTable.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable  #-}

module Phoityne.IO.GUI.GTK.BreakPointTable (
  BreakPointListStore
, BreakPointData(..)
, BreakPointDataKey
, getBreakCondition
, DeleteAllBreakBTClickedEventHandler
, BreakPointTableDoubleClickedHandler
, setupBreakPointTable
, createBreakPointListStore
, addBreakPoint2Table
, deleteFromBreakPointListStore
, getBreakPointList
, updateBreakPointTable
, findBreakPointData
, highLightBreakPointTableRow
) where

-- モジュール
import Phoityne.Constant
import Phoityne.IO.GUI.GTK.Constant
import Phoityne.IO.GUI.GTK.Utility

-- システム
import Graphics.UI.Gtk
import Control.Monad.IO.Class
import System.Log.Logger
import qualified Data.List as L

-- |
--  
-- 
data BreakPointData =
  BreakPointData {
    moduleNameBreakPointData :: String
  , filePathBreakPointData   :: FilePath
  , lineNoBreakPointData     :: Int
  , breakNoBreakPointData    :: Maybe Int
  , conditionBreakPointData  :: String
  } deriving (Show, Read, Eq, Ord)

-- |
--
--
type BreakPointTableDoubleClickedHandler = BreakPointData -> IO ()

-- |
--  
-- 
type BreakPointDataKey = (FilePath, Int)

-- |
--  
-- 
type BreakPointListStore = ListStore BreakPointData

-- |
--  
-- 
type DeleteAllBreakBTClickedEventHandler = IO ()

-- |
--
--
createBreakPointListStore :: IO BreakPointListStore
createBreakPointListStore = listStoreNew ([] :: [BreakPointData])

-- |
--
--
setupBreakPointTable :: Builder
                     -> BreakPointListStore
                     -> BreakPointTableDoubleClickedHandler
                     -> DeleteAllBreakBTClickedEventHandler
                     -> IO ()
setupBreakPointTable builder store evh deleteEvh = do

  treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW
  _ <- treeViewSetModel treeView store

  col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol1" :: String)
  renderer <- cellRendererTextNew
  cellLayoutPackStart col renderer True
  cellLayoutSetAttributes col renderer store $ \cell -> 
    [ cellText := moduleNameBreakPointData cell
    , cellTextFont := _FONT_DESC
    , cellTextSize := 9
    ]

  col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol2" :: String)
  renderer <- cellRendererTextNew
  cellLayoutPackStart col renderer True
  cellLayoutSetAttributes col renderer store $ \cell -> 
    [ cellText := filePathBreakPointData cell
    , cellTextFont := _FONT_DESC
    , cellTextSize := 9
    ]

  col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol3" :: String)
  renderer <- cellRendererTextNew
  cellLayoutPackStart col renderer True
  cellLayoutSetAttributes col renderer store $ \cell -> 
    [ cellText := show (lineNoBreakPointData cell)
    , cellTextFont := _FONT_DESC
    , cellTextSize := 9
    ]

  col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol4" :: String)
  renderer <- cellRendererTextNew
  cellLayoutPackStart col renderer True
  cellLayoutSetAttributes col renderer store $ \cell -> 
    [ cellText := conditionBreakPointData cell
    , cellTextFont := _FONT_DESC
    , cellTextSize := 9
    ]
  set renderer [cellTextEditable := True]
  _ <- on renderer edited $ breakPointsConditionEditedHandler treeView store

  _ <- on treeView buttonPressEvent $ breakPointTableDoubleClickedHandler treeView store evh

  sel <- treeViewGetSelection treeView
  treeSelectionSetMode sel SelectionSingle

  bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DELETE
  onToolButtonClicked bt deleteEvh
  widgetSetSensitive bt True

  setFont treeView
  widgetShowAll treeView


-- |
--
--
breakPointsConditionEditedHandler :: TreeView -> ListStore BreakPointData -> TreePath -> String -> IO ()
breakPointsConditionEditedHandler treeView listStore treePath value = do
  treeViewGetModel treeView >>= \case
    Nothing    -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]model not found."
    Just model -> withModel model

  where
    withModel model = treeModelGetIter model treePath >>= \case
      Nothing   -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]treeIter not found."
      Just iter -> newData iter >>= listStoreSetValue listStore (listStoreIterToIndex iter)

    newData iter = do
      dat <- listStoreGetValue listStore (listStoreIterToIndex iter)
      return  dat{conditionBreakPointData = value}

-- |
--
--
breakPointTableDoubleClickedHandler :: TreeView -> ListStore BreakPointData -> BreakPointTableDoubleClickedHandler -> EventM EButton Bool
breakPointTableDoubleClickedHandler self listStore evh = eventClick >>= \case
  DoubleClick -> liftIO $ do
    sel <- treeViewGetSelection self
    treeSelectionGetSelected sel >>= \case
      Nothing   -> return False
      Just iter -> do
        let idx = listStoreIterToIndex iter
        bpDat <- listStoreGetValue listStore idx
        evh bpDat
        return False

  _ -> return False


-- |
--  
--
addBreakPoint2Table :: BreakPointListStore -> BreakPointData -> IO ()
addBreakPoint2Table = add2ListStore

-- |
--  
-- 
deleteFromBreakPointListStore :: ListStore BreakPointData -> BreakPointDataKey -> IO ()
deleteFromBreakPointListStore store (path, lineNo) = 
  treeModelForeach (castToTreeModel store) deleteData
  where
    deleteData iter = do
      let idx = listStoreIterToIndex iter
      (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx
      if (curPath == path) && (curLineNo == lineNo) then listStoreRemove store idx >> return True
        else return False

-- |
--  
-- 
updateBreakPointTable :: ListStore BreakPointData -> BreakPointDataKey -> BreakPointData -> IO ()
updateBreakPointTable store (path, lineNo) newDat = do
  treeModelForeach (castToTreeModel store) updateData
  where
    updateData iter = do
      let idx = listStoreIterToIndex iter
      (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx
      if (curPath == path) && (curLineNo == lineNo) then listStoreSetValue store idx newDat >> return True
        else return False

-- |
--  
-- 
findBreakPointData :: ListStore BreakPointData -> BreakPointDataKey -> IO (Maybe BreakPointData)
findBreakPointData store (path, lineNo) = do
  xs <- listStoreToList store 
  return $ L.find findData xs
  where
    findData (BreakPointData _ curPath curLineNo _ _) = (curPath == path) && (curLineNo == lineNo)

-- |
--  
-- 
getBreakPointList :: ListStore a -> IO [a]
getBreakPointList = listStoreToList

-- |
--  
--
highLightBreakPointTableRow :: Builder -> ListStore BreakPointData -> BreakPointDataKey -> IO ()
highLightBreakPointTableRow builder listStore (path, lineNo) = do
  treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW
  sel      <- treeViewGetSelection treeView
  treeViewGetModel treeView >>= \case
    Nothing    -> errorM _LOG_NAME $ "[highLightBreakPointTableRow]invalid highlight break point table."
    Just model -> treeModelForeach model $ highLight sel

  where
    highLight sel iter = do
      let idx = listStoreIterToIndex iter
      (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue listStore idx
      if (L.isSuffixOf path curPath) && (curLineNo == lineNo) then treeSelectionSelectIter sel iter >> return True
        else return False

-- |
--  
--
getBreakCondition :: ListStore BreakPointData -> BreakPointDataKey -> IO String
getBreakCondition listStore (path, lineNo) = do
  bps <- listStoreToList listStore
  case L.find go bps of
    Nothing -> do
      errorM _LOG_NAME $ "[getBreakCondition]invalid break point data. " ++ path ++ ":" ++ show lineNo
      return ""
    Just (BreakPointData _ _ _ _ condStr) -> return condStr
  where
    go (BreakPointData _ curPath curLineNo _ _) = (L.isSuffixOf curPath path) && (curLineNo == lineNo)