{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Phoityne.IO.GUI.Control (
createMainWindow
, DebugCommandData(..)
) where
-- モジュール
import Phoityne.Constant
import Phoityne.Utility
import Phoityne.IO.Utility
import qualified Phoityne.IO.GUI.GTK.Interface as IF
-- システム
import System.Exit
import System.FilePath
import System.Directory
import System.Log.Logger
import Control.Monad
import Control.Concurrent
import Data.Maybe
import Data.String.Utils
import Data.Char
import Data.Functor.Identity
import Text.Parsec
import qualified Data.Map as Map
import qualified Data.List as L
import qualified Data.Tree as T
import qualified Data.Text as TE
import qualified Data.Text.Encoding as TE
import qualified Text.StringTemplate as TPL
-- |
--
--
type NoteMap = Map.Map IF.NodeData IF.TextEditorData
-- |
--
--
data UndoRedoData =
DeleteRangeUndoRedoData {
filePathDeleteRangeUndoRedoData :: FilePath
, startLineNoDeleteRangeUndoRedoData :: Int
, startColNoDeleteRangeUndoRedoData :: Int
, endLineNoDeleteRangeUndoRedoData :: Int
, endColNoDeleteRangeUndoRedoData :: Int
, textDeleteRangeUndoRedoData :: String
} |
InsertTextUndoRedoData {
filePathInsertTextUndoRedoData :: FilePath
, startLineNoInsertTextUndoRedoData :: Int
, startColNoInsertTextUndoRedoData :: Int
, textInsertTextUndoRedoData :: String
}
deriving (Show, Read, Eq, Ord)
-- |
--
--
data MVarGUIData =
MVarGUIData {
widgetStoreMVarGUIData :: IF.WidgetStore
, breakPointListMVarGUIData :: IF.BreakPointListStore
, codeNoteMapMVarGUIData :: NoteMap
, folderTreeMVarGUIData :: IF.FolderTreeStore
, bindingListStoreMVarGUIData :: IF.BindingListStore
, traceListStoreMVarGUIData :: IF.TraceDataListStore
, searchResultListStoreMVarGUIData :: IF.SearchResultListStore
, traceIdMVarGUIData :: Int
, undoBufferMVarGUIData :: [UndoRedoData]
, redoBufferMVarGUIData :: [UndoRedoData]
, unDoReDoFlagMVarGUIData :: Bool
, searchFilesMVarGUIData :: [FilePath]
, startupNodeDataMVarGUIData :: Maybe IF.NodeData
, ghciAutoStart :: Bool
}
-- |
--
--
data DebugCommandData =
DebugCommandData {
startDebugCommandData :: IO ()
, stopDebugCommandData :: IO ExitCode
, readDebugCommandData :: IO String
, readLinesDebugCommandData :: ([String] -> IO Bool) -> IO [String]
, promptDebugCommandData :: IO String
, breakDebugCommandData :: ModuleName -> Int -> IO String
, bindingsDebugCommandData :: IO String
, runDebugCommandData :: Bool -> IO String
, continueDebugCommandData :: Bool -> IO String
, stepDebugCommandData :: IO String
, stepOverDebugCommandData :: IO String
, printEvldDebugCommandData :: IO String
, deleteBreakDebugCommandData :: Int -> IO String
, traceHistDebugCommandData :: IO String
, traceBackDebugCommandData :: IO String
, traceForwardDebugCommandData :: IO String
, forceDebugCommandData :: String -> IO String
, execCommandData :: String -> IO String
, quitDebugCommandData :: IO String
, buildStartDebugCommandData :: IO ()
, cleanStartDebugCommandData :: IO ()
, loadFileDebugCommandData :: FilePath -> IO String
, readWhileDebugCommandData :: (String -> Bool) -> IO String
, infoDebugCommandData :: String -> IO String
}
-- |
--
--
data HighlightTextRangeData = HighlightTextRangeData {
filePathHighlightTextRangeData :: FilePath
, startLineNoHighlightTextRangeData :: Int
, startColNoHighlightTextRangeData :: Int
, endLineNoHighlightTextRangeData :: Int
, endColNoHighlightTextRangeData :: Int
} deriving (Show, Read, Eq, Ord)
-- |
--
--
getKeyOfHighlightTextRangeData :: HighlightTextRangeData -> IF.BreakPointDataKey
getKeyOfHighlightTextRangeData (HighlightTextRangeData file line _ _ _) = (file, line)
-- |
--
--
defaultMVarGUIData :: IF.WidgetStore
-> IF.BreakPointListStore
-> IF.FolderTreeStore
-> IF.BindingListStore
-> IF.TraceDataListStore
-> IF.SearchResultListStore
-> Bool
-> MVarGUIData
defaultMVarGUIData widgets breaks folder bindings trace search autoRun =
MVarGUIData {
widgetStoreMVarGUIData = widgets
, breakPointListMVarGUIData = breaks
, codeNoteMapMVarGUIData = Map.fromList []
, folderTreeMVarGUIData = folder
, bindingListStoreMVarGUIData = bindings
, traceListStoreMVarGUIData = trace
, searchResultListStoreMVarGUIData = search
, traceIdMVarGUIData = 0
, undoBufferMVarGUIData = []
, redoBufferMVarGUIData = []
, unDoReDoFlagMVarGUIData = False
, searchFilesMVarGUIData = []
, startupNodeDataMVarGUIData = Nothing
, ghciAutoStart = autoRun
}
-- |
--
--
createMainWindow :: DebugCommandData -> [FilePath] -> Bool -> (String, Int) -> IO ()
createMainWindow cmdData paths autoRun systemFont = do
-- Storeの作成
builder <- IF.getBuilder
breakStore <- IF.createBreakPointListStore
bindingStore <- IF.createBindingListStore
traceStore <- IF.createTraceDataListStore
searchResultStore <- IF.createSearchResultListStore
treeNodes@(T.Node rootNode _) <- loadFolderForest _PROJECT_ROOT_MODULE_NAME paths
treeStore <- IF.createTreeStore treeNodes
-- GUI共有データの作成
mvarGUI <- newMVar $ defaultMVarGUIData builder breakStore treeStore bindingStore traceStore searchResultStore autoRun
-- イベントハンドラの登録
IF.setupMainWindow builder ("Phoityne [" ++ (IF.getPathFromNodeData rootNode) ++ "]") systemFont
(mainWindowCloseEventHanlder mvarGUI cmdData)
(mainWindowKeyPressEventHandler mvarGUI cmdData)
(textEditorSwitchPageEventHandler mvarGUI cmdData)
IF.setupToolButton builder
(toolBTdebugStartHandler mvarGUI cmdData)
(toolBTdebugStopHandler mvarGUI cmdData)
(toolBTstepOverHandler mvarGUI cmdData)
(toolBTstepInHandler mvarGUI cmdData)
(toolBTcontinueHandler mvarGUI cmdData)
(toolBTbuildHandler mvarGUI cmdData)
(toolBTsaveHandler mvarGUI cmdData)
(toolBTindentHandler mvarGUI)
(toolBTunIndentHandler mvarGUI)
(toolBTcommentHandler mvarGUI)
(toolBTunCommentHandler mvarGUI)
(toolBTstartGHCiHandler mvarGUI cmdData)
(toolBTstopGHCiHandler mvarGUI cmdData)
IF.setupFolderTree builder treeStore
(folderTreeDoubleClickedHandler mvarGUI cmdData)
(folderTreePopupHandler mvarGUI)
(folderTreeCreateFolderAction mvarGUI)
(folderTreeCreateFileAction mvarGUI cmdData)
(folderTreeRenameAction mvarGUI)
(folderTreeDeleteAction mvarGUI)
(folderTreeSearchAction mvarGUI cmdData)
(folderTreeReplaceAction mvarGUI cmdData)
(folderTreeKeyPressEventHandler mvarGUI cmdData)
(folderTreeStartupAction mvarGUI cmdData)
IF.setupConsoleView builder
(consoleDoubleClickedHandler mvarGUI cmdData)
IF.setupBreakPointTable builder breakStore
(breakPointTableDoubleClickedHandler mvarGUI cmdData)
(toolBTdeleteHandler mvarGUI cmdData)
IF.setupBindingTable builder bindingStore
(bindingTableDoubleClickedHandler mvarGUI cmdData)
IF.setupTraceTable builder traceStore
(traceTableDoubleClickedHandler mvarGUI cmdData)
IF.setupSearchResultTable builder searchResultStore
(searchResultTableDoubleClickedHandler mvarGUI cmdData)
autoRunGHCi mvarGUI cmdData
-- 開始
IF.start builder
-- |=====================================================================
-- MainWindowのイベントハンドラ
--
-- |
--
--
mainWindowCloseEventHanlder :: MVar MVarGUIData -> DebugCommandData -> IF.MainWindowCloseEventHandler
mainWindowCloseEventHanlder mvarGUI cmdDat = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
isGhciStarted <- IF.isGHCiStarted builder
when isGhciStarted $ toolBTstopGHCiHandler mvarGUI cmdDat
infoM _LOG_NAME "See you again."
-- |
--
--
mainWindowKeyPressEventHandler :: MVar MVarGUIData -> DebugCommandData -> IF.MainWindowKeyPressEventHandler
mainWindowKeyPressEventHandler mvarGUI cmdDat "F5" isShift _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
isStart <- IF.isDebugStarted builder
withStart isStart isShift
return True
where
withStart True True = toolBTdebugStopHandler mvarGUI cmdDat
withStart True False = toolBTcontinueHandler mvarGUI cmdDat
withStart False False = toolBTdebugStartHandler mvarGUI cmdDat
withStart _ _ = return ()
mainWindowKeyPressEventHandler mvarGUI cmdDat "F7" True _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.isBuildStarted builder >>= \case
True -> IF.putStrStatusBar builder "build unavailable. Currently building."
False -> IF.isGHCiStarted builder >>= \case
True -> IF.putStrStatusBar builder "build unavailable. Currently ghci running."
False -> IF.clearConsole builder >> runClean >> runBuild mvarGUI cmdDat
return True
where
runClean = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
cleanCmd = cleanStartDebugCommandData cmdDat
readLine = readLinesDebugCommandData cmdDat
exitCmd = stopDebugCommandData cmdDat
IF.clearConsole builder
IF.putStrConsole builder $ "% stack clean \n"
cleanCmd
readLine $ cleanResultHandler mvarGUI
code <- exitCmd
IF.putStrLnConsole builder $ show code
cleanResultHandler :: MVar MVarGUIData -> [String] -> IO Bool
cleanResultHandler _ [] = return False
cleanResultHandler mvarGUI strs = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.putStrLnConsole builder $ last strs
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "F7" _ _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.isBuildStarted builder >>= \case
True -> IF.putStrStatusBar builder "build unavailable. Currently building."
False -> IF.isGHCiStarted builder >>= \case
True -> IF.putStrStatusBar builder "build unavailable. Currently ghci running."
False -> do
IF.clearConsole builder
runBuild mvarGUI cmdDat
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "F8" isShift _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.isBuildStarted builder >>= \case
True -> IF.putStrStatusBar builder "ghci unavailable. Currently build running." >> return True
False -> do
isGHCiStart <- IF.isGHCiStarted builder
withStart builder isGHCiStart isShift
return True
where
withStart _ True True = toolBTstopGHCiHandler mvarGUI cmdDat
withStart builder True False = IF.putStrStatusBar builder "ghci has already been started."
withStart builder False True = IF.putStrStatusBar builder "ghci has already been stopped."
withStart _ False False = toolBTstartGHCiHandler mvarGUI cmdDat
mainWindowKeyPressEventHandler mvarGUI cmdDat "F10" _ _ = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
isStart <- IF.isDebugStarted builder
putMVar mvarGUI guiData
if isStart then toolBTstepOverHandler mvarGUI cmdDat
else return ()
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "F11" _ _ = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
isStart <- IF.isDebugStarted builder
putMVar mvarGUI guiData
if isStart then toolBTstepInHandler mvarGUI cmdDat
else return ()
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "s" _ True = do
saveAll mvarGUI cmdDat >>= loadHsFiles mvarGUI cmdDat
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "f" _ True = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[mainWindowKeyPressEventHandler] invalid text editor." >> return True
Just a -> withEditor a
where
withEditor (nodeData, editor) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = searchResultListStoreMVarGUIData guiData
defaultStr <- IF.getSelectedText editor
IF.getSearchKeyBySearchDialog builder defaultStr >>= \case
(Nothing, _) -> return True
(Just key, isLower) -> do
runSearch mvarGUI cmdDat [nodeData] (key, isLower)
(lineNo, _) <- IF.getCodeTextLineNumber editor
IF.nextCurrentSearchResult builder store $ Just (IF.getPathFromNodeData nodeData, lineNo+2)
updateSearchResultTag mvarGUI cmdDat (IF.getPathFromNodeData nodeData) editor
activateTextEditorWithSearchResult mvarGUI cmdDat
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "r" _ True = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[mainWindowKeyPressEventHandler] invalid text editor." >> return True
Just a -> withEditor a
where
withEditor (nodeData, editor) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = searchResultListStoreMVarGUIData guiData
nodeDatas = [nodeData]
rangeMay <- IF.getSelectedRange editor
IF.getReplaceByReplaceDialog builder (getRangeInfo rangeMay) >>= \case
Nothing -> return True
Just (key, rep) -> do
saveAll mvarGUI cmdDat
replaceFiles nodeDatas rangeMay key rep
reloadAll mvarGUI
runSearch mvarGUI cmdDat nodeDatas (rep, False)
(lineNo, _) <- IF.getCodeTextLineNumber editor
IF.nextCurrentSearchResult builder store $ Just (IF.getPathFromNodeData nodeData, lineNo+2)
updateSearchResultTag mvarGUI cmdDat (IF.getPathFromNodeData nodeData) editor
activateTextEditorWithSearchResult mvarGUI cmdDat
return True
getRangeInfo Nothing = "ALL"
getRangeInfo (Just (s, e)) = "L" ++ show (s+1) ++ " - L" ++ show (e+1)
mainWindowKeyPressEventHandler mvarGUI cmdDat "F3" isShift _ = do
autoSearch mvarGUI cmdDat
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = searchResultListStoreMVarGUIData guiData
if True == isShift then IF.prevCurrentSearchResult builder store
else IF.nextCurrentSearchResult builder store Nothing
activateTextEditorWithSearchResult mvarGUI cmdDat
return True
mainWindowKeyPressEventHandler _ _ _ _ _ = return False
-- |=====================================================================
-- ToolButtonのイベントハンドラ
--
-- |
-- Event Handler
--
toolBTdebugStartHandler :: MVar MVarGUIData -> DebugCommandData -> IF.DebugStartBTClickedEventHandler
toolBTdebugStartHandler mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.isGHCiStarted builder >>= \case
False -> errorM _LOG_NAME "ghci has not yet started."
True -> loadHsFileInternal >>= \case
True -> startDebug
False -> do
let msg = "load startup module fail. check startup module set."
warningM _LOG_NAME msg
IF.putStrStatusBar builder msg
where
loadHsFileInternal = do
guiData <- readMVar mvarGUI
loadHsFileMay $ startupNodeDataMVarGUIData guiData
loadHsFileMay Nothing = return False
loadHsFileMay (Just nodeDat) = loadHsFile mvarGUI cmdData $ IF.getPathFromNodeData nodeDat
startDebug = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
breakStore = breakPointListMVarGUIData guiData
getResult = readDebugCommandData cmdData
runDebug = runDebugCommandData cmdData
IF.changeTBsOnDebugStarted builder
breakList <- IF.getBreakPointList breakStore
mapM_ (addBreakPointOnCUI mvarGUI cmdData) breakList
cmdStr <- runDebug True
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
let breakPos = getStoppedTextRangeData cmdStr
case breakPos of
Left err -> do
infoM _LOG_NAME $ show err
IF.changeTBsOnDebugStopped builder
Right pos -> continueWithHighlightTextRangeData mvarGUI cmdData pos
-- |
--
--
loadHsFiles :: MVar MVarGUIData -> DebugCommandData -> [FilePath] -> IO ()
loadHsFiles mvarGUI cmdData paths = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
debugStarted <- IF.isDebugStarted builder
when debugStarted $ do
IF.putStrStatusBar builder "stop debug and load files."
toolBTdebugStopHandler mvarGUI cmdData
autoRunGHCi mvarGUI cmdData >>= \case
False -> return ()
True -> mapM_ (loadHsFile mvarGUI cmdData) paths
-- |
--
--
loadHsFile :: MVar MVarGUIData -> DebugCommandData -> FilePath -> IO Bool
loadHsFile mvarGUI cmdData path
| (False == endswith _HS_FILE_EXT path) = return False
| otherwise = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
loadFile = loadFileDebugCommandData cmdData
readLines = readLinesDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- loadFile path
IF.putStrLnConsole builder cmdStr
cont <- readLines (debugStartResultHandler builder)
if | null cont -> return False
| startswith "Ok," (last cont) -> do
cmdStr <- getResult
IF.putStrConsole builder cmdStr
return True
| startswith "Failed," (last cont) -> do
cmdStr <- getResult
IF.putStrConsole builder cmdStr
return False
| otherwise -> do
errorM _LOG_NAME $ "load file fail.["++ path ++"]"
return False
where
debugStartResultHandler :: IF.WidgetStore -> [String] -> IO Bool
debugStartResultHandler builder acc = IF.putStrLnConsole builder curStr >> if
| L.isPrefixOf "Ok," curStr -> return False
| L.isPrefixOf "Failed," curStr -> return False
| otherwise -> return True
where
curStr | null acc = ""
| otherwise = last acc
-- |
--
--
autoRunGHCi :: MVar MVarGUIData -> DebugCommandData -> IO Bool
autoRunGHCi mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
autoRun = ghciAutoStart guiData
isGHCiStarted <- IF.isGHCiStarted builder
withFlag autoRun isGHCiStarted
where
withFlag _ True = return True
withFlag False _ = do
infoM _LOG_NAME "ghci auto run disabled." >> return False
withFlag True False = runGHCi mvarGUI cmdData >>= \case
True -> return True
False -> errorM _LOG_NAME "run ghci failed." >> return False
-- |
--
--
runGHCi :: MVar MVarGUIData -> DebugCommandData -> IO Bool
runGHCi mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
startCmd = startDebugCommandData cmdData
readWhile = readWhileDebugCommandData cmdData
IF.changeTBsOnGHCiStartting builder
IF.clearConsole builder
IF.putStrConsole builder $ "% stack ghci --test --no-load --no-build \n"
startCmd
str <- readWhile $ not . endswith _GHCI_PROMPT
IF.putStrLnConsole builder str
withStarted builder $ endswith _GHCI_PROMPT str
where
withStarted builder False = do
IF.changeTBsOnGHCiStopped builder
return False
withStarted builder True = do
readAndSetPrompt
IF.changeTBsOnGHCiStarted builder
return True
readAndSetPrompt = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
setPrompt = promptDebugCommandData cmdData
getResult = readDebugCommandData cmdData
printEvld = printEvldDebugCommandData cmdData
promptStr <- setPrompt
IF.putStrLnConsole builder promptStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
cmdStr <- printEvld
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
-- |
-- Event Handler
--
toolBTdebugStopHandler :: MVar MVarGUIData -> DebugCommandData -> IF.DebugStopBTClickedEventHandler
toolBTdebugStopHandler mvarGUI _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.changeTBsOnDebugStopped builder
-- |
-- Event Handler
--
toolBTstepOverHandler :: MVar MVarGUIData -> DebugCommandData -> IF.StepOverBTClickedEventHandler
toolBTstepOverHandler mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
bindStore = bindingListStoreMVarGUIData guiData
stepOver = stepOverDebugCommandData cmdData
getResult = readDebugCommandData cmdData
bindings = bindingsDebugCommandData cmdData
cmdStr <- stepOver
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
let breakPos = getStoppedTextRangeData cmdStr
_ <- bindings
bindStr <- getResult
case getBindingDataList bindStr of
Left err -> warningM _LOG_NAME $ show err
Right dats -> IF.updateBindingTable bindStore dats
case breakPos of
Left err -> do
infoM _LOG_NAME $ show err
IF.changeTBsOnDebugStopped builder
Right pos -> activateTextEditor mvarGUI cmdData pos
return ()
-- |
-- Event Handler
--
toolBTstepInHandler :: MVar MVarGUIData -> DebugCommandData -> IF.StepInBTClickedEventHandler
toolBTstepInHandler mvarGUI cmdData = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
bindStore = bindingListStoreMVarGUIData guiData
step = stepDebugCommandData cmdData
getResult = readDebugCommandData cmdData
bindings = bindingsDebugCommandData cmdData
putMVar mvarGUI guiData
cmdStr <- step
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
let breakPos = getStoppedTextRangeData cmdStr
_ <- bindings
bindStr <- getResult
case getBindingDataList bindStr of
Left err -> warningM _LOG_NAME $ show err
Right dats -> IF.updateBindingTable bindStore dats
case breakPos of
Left err -> do
infoM _LOG_NAME $ show err
IF.changeTBsOnDebugStopped builder
Right pos -> activateTextEditor mvarGUI cmdData pos
return ()
-- |
-- Event Handler
--
toolBTcontinueHandler :: MVar MVarGUIData -> DebugCommandData -> IF.StepInBTClickedEventHandler
toolBTcontinueHandler mvarGUI cmdData = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
continue = continueDebugCommandData cmdData
getResult = readDebugCommandData cmdData
putMVar mvarGUI guiData
cmdStr <- continue True
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
let breakPos = getStoppedTextRangeData cmdStr
case breakPos of
Left err -> do
infoM _LOG_NAME $ show err
IF.changeTBsOnDebugStopped builder
Right pos -> continueWithHighlightTextRangeData mvarGUI cmdData pos
-- |
-- Event Handler
--
toolBTbuildHandler :: MVar MVarGUIData -> DebugCommandData -> IF.BuildBTClickedEventHandler
toolBTbuildHandler mvarGUI cmdData = do
guiData <- readMVar mvarGUI
IF.clearConsole $ widgetStoreMVarGUIData guiData
runBuild mvarGUI cmdData
-- |
-- Event Handler
--
runBuild :: MVar MVarGUIData -> DebugCommandData -> IF.BuildBTClickedEventHandler
runBuild mvarGUI cmdData = do
debugM _LOG_NAME "save all file."
saveAll mvarGUI cmdData
debugM _LOG_NAME "thread starting."
_ <- forkIO $ do
debugM _LOG_NAME "thread started."
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
buildStart = buildStartDebugCommandData cmdData
readLine = readLinesDebugCommandData cmdData
exitCmd = stopDebugCommandData cmdData
debugM _LOG_NAME "read info."
IF.addCallback (IF.changeTBsOnBuildStart builder >> return False)
debugM _LOG_NAME "build start."
IF.putStrLnConsoleAsync builder "% stack build --test --no-run-tests \n"
buildStart
debugM _LOG_NAME "build started."
readLine (buildResultHandler mvarGUI)
code <- exitCmd
IF.putStrLnConsoleAsync builder $ "\n" ++ show code ++ "\n"
IF.addCallback (IF.changeTBsOnBuildFinish builder >> return False)
return ()
return ()
where
buildResultHandler :: MVar MVarGUIData -> [String] -> IO Bool
buildResultHandler _ [] = return False
buildResultHandler mvarGUI strs = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.putStrLnConsoleAsync builder $ last strs
return True
-- |
-- Event Handler
--
toolBTdeleteHandler :: MVar MVarGUIData -> DebugCommandData -> IF.DeleteAllBreakBTClickedEventHandler
toolBTdeleteHandler mvarGUI cmdData = do
guiData <- takeMVar mvarGUI
let bpList = breakPointListMVarGUIData guiData
--noteMap = codeNoteMapMVarGUIData guiData
--mapM_ IF.offLightBreakPoint $ Map.elems noteMap
putMVar mvarGUI guiData
IF.getBreakPointList bpList >>= mapM_ go
where
go (IF.BreakPointData _ path lineNo _ _) = do
let bpKey = (path, lineNo)
deleteBreakPointOnCUI mvarGUI cmdData bpKey
deleteBreakPointOnBPTable mvarGUI bpKey
deleteBreakPointTag mvarGUI bpKey
-- |
-- Event Handler
--
toolBTsaveHandler :: MVar MVarGUIData -> DebugCommandData -> IF.SaveBTClickedEventHandler
toolBTsaveHandler mvarGUI cmdData = do
files <- saveAll mvarGUI cmdData
loadHsFiles mvarGUI cmdData files
-- |
-- Event Handler
--
toolBTindentHandler :: MVar MVarGUIData -> IF.IndentBTClickedEventHandler
toolBTindentHandler mvarGUI = findCurrentTextEditor mvarGUI >>= \case
Nothing -> return()
Just (_, editor) -> IF.blockIndentTextEditor editor
-- |
-- Event Handler
--
toolBTunIndentHandler :: MVar MVarGUIData -> IF.UnIndentBTClickedEventHandler
toolBTunIndentHandler mvarGUI = findCurrentTextEditor mvarGUI >>= \case
Nothing -> return()
Just (_, editor) -> IF.blockUnIndentTextEditor editor
-- |
-- Event Handler
--
toolBTcommentHandler :: MVar MVarGUIData -> IF.CommentBTClickedEventHandler
toolBTcommentHandler mvarGUI = findCurrentTextEditor mvarGUI >>= \case
Nothing -> return()
Just (_, editor) -> IF.blockCommentTextEditor editor
-- |
-- Event Handler
--
toolBTunCommentHandler :: MVar MVarGUIData -> IF.UnCommentBTClickedEventHandler
toolBTunCommentHandler mvarGUI = findCurrentTextEditor mvarGUI >>= \case
Nothing -> return()
Just (_, editor) -> IF.blockUnCommentTextEditor editor
-- |
-- Event Handler
--
toolBTstartGHCiHandler :: MVar MVarGUIData -> DebugCommandData -> IO ()
toolBTstartGHCiHandler mvarGUI cmdData = runGHCi mvarGUI cmdData >>= \case
True -> return ()
False -> errorM _LOG_NAME "run ghci failed."
-- |
-- Event Handler
--
toolBTstopGHCiHandler :: MVar MVarGUIData -> DebugCommandData -> IO ()
toolBTstopGHCiHandler mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
--codeNoteMap = codeNoteMapMVarGUIData guiData
exitCmd = stopDebugCommandData cmdData
quitCmd = quitDebugCommandData cmdData
readWhile = readWhileDebugCommandData cmdData
cmdStr <- quitCmd
IF.putStrLnConsole builder cmdStr
str <- readWhile $ const True
IF.putStrConsole builder str
IF.putStrLnConsole builder ""
code <- exitCmd
IF.putStrLnConsole builder $ show code
IF.changeTBsOnGHCiStopped builder
--mapM_ IF.offLightBreakPoint $ Map.elems codeNoteMap
return ()
-- |
--
--
continueWithHighlightTextRangeData :: MVar MVarGUIData -> DebugCommandData -> HighlightTextRangeData -> IO ()
continueWithHighlightTextRangeData mvarGUI cmdData pos = do
guiData <- takeMVar mvarGUI
let breakStore = breakPointListMVarGUIData guiData
condCmd <- IF.getBreakCondition breakStore $ getKeyOfHighlightTextRangeData pos
putMVar mvarGUI guiData
continueWithCondCmd mvarGUI cmdData pos condCmd
where
continueWithCondCmd mvarGUI cmdData pos condCmd
| null condCmd = continueWithCondResult mvarGUI cmdData pos True
| otherwise = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
condition = execCommandData cmdData
getResult = readDebugCommandData cmdData
putMVar mvarGUI guiData
_ <- condition condCmd
IF.putStrLnConsole builder condCmd
cmdStr <- getResult
IF.putStrConsole builder cmdStr
condRes <- getConditionResult cmdStr
continueWithCondResult mvarGUI cmdData pos condRes
continueWithCondResult mvarGUI cmdData _ False = toolBTcontinueHandler mvarGUI cmdData
continueWithCondResult mvarGUI cmdData pos True = do
updateBindingTable mvarGUI cmdData
updateTraceTable mvarGUI cmdData
activateTextEditor mvarGUI cmdData pos
getConditionResult res
| L.isPrefixOf "True" res = return True
| L.isPrefixOf "False" res = return False
| otherwise = warningM _LOG_NAME ("invalid condition result. " ++ res) >> return True
-- |
-- continueWithHighlightTextRangeDataで使用している
--
updateBindingTable :: MVar MVarGUIData -> DebugCommandData -> IO ()
updateBindingTable mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let bindStore = bindingListStoreMVarGUIData guiData
bindings = bindingsDebugCommandData cmdData
getResult = readDebugCommandData cmdData
_ <- bindings
bindStr <- getResult
case getBindingDataList bindStr of
Left err -> errorM _LOG_NAME $ show err
Right dats -> IF.updateBindingTable bindStore dats
-- |
-- continueWithHighlightTextRangeDataで使用している
--
updateTraceTable :: MVar MVarGUIData -> DebugCommandData -> IO ()
updateTraceTable mvarGUI cmdData = do
guiData <- takeMVar mvarGUI
let traceStore = traceListStoreMVarGUIData guiData
getResult = readDebugCommandData cmdData
history = traceHistDebugCommandData cmdData
_ <- history
traceStr <- getResult
case getTraceDataList traceStr of
Left err -> errorM _LOG_NAME $ show err
Right dats -> IF.updateTraceTable traceStore dats
putMVar mvarGUI guiData {traceIdMVarGUIData = 0}
-- |=====================================================================
-- FolderTreeのイベントハンドラ
--
-- |
-- Event Handler
-- フォルダーツリーでファイルがダブルクリックされた場合に
-- コードノートを表示する。
--
folderTreeDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeDoubleClickedHandler
folderTreeDoubleClickedHandler mvarGUI cmdDat = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
IF.getSelectedFolderTreeNodeData builder treeStore >>= withNodeData
where
withNodeData (Just (IF.FileNodeData _ _ path)) = do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path (-1)
withNodeData (Just (IF.FolderNodeData _ _ _)) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
IF.expandCollapseFolderTree builder store
withNodeData _ = return ()
-- |
-- Event Handler
--
folderTreePopupHandler :: MVar MVarGUIData -> IF.FolderTreePopupHandler
folderTreePopupHandler mvarGUI = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
nodeData <- IF.getSelectedFolderTreeNodeData builder treeStore
IF.folderTreeMenuPopup builder nodeData
putMVar mvarGUI guiData
-- |
-- Event Handler
--
folderTreeCreateFolderAction :: MVar MVarGUIData -> IF.FolderTreeCreateFolderAction
folderTreeCreateFolderAction mvarGUI = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
nodeData <- IF.getSelectedFolderTreeNodeData builder treeStore
nameMay <- IF.getNameByFolderTreeDialog builder "Create Folder" "Input folder name." "" True
case getFolderTreeNodeData nodeData nameMay of
Nothing -> return () -- canceled.
Just (IF.FileNodeData _ _ _) -> return ()
Just child@(IF.FolderNodeData _ _ path) -> do
createDirectory path
IF.addNode2TreeStore treeStore (fromJust nodeData) child
putMVar mvarGUI guiData{folderTreeMVarGUIData = treeStore}
where
getFolderTreeNodeData :: Maybe IF.NodeData -> Maybe String -> Maybe IF.NodeData
getFolderTreeNodeData (Just (IF.FolderNodeData modName _ path)) (Just name) =
Just $ IF.FolderNodeData (getModName modName name) name (path > name)
getFolderTreeNodeData _ _ = Nothing
getModName :: String -> String -> String
getModName parent child
| null parent = child
| otherwise = parent ++ "." ++ child
-- |
-- Event Handler
--
folderTreeCreateFileAction :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeCreateFileAction
folderTreeCreateFileAction mvarGUI cmdDat = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
nodeData <- IF.getSelectedFolderTreeNodeData builder treeStore
nameMay <- IF.getNameByFolderTreeDialog builder "Create File" "Input file name." "" True
case getFileTreeNodeData nodeData nameMay of
Nothing -> putMVar mvarGUI guiData
Just (IF.FolderNodeData _ _ _) -> return ()
Just child@(IF.FileNodeData modName _ path) -> do
saveFileLBS path $ str2lbs $ code modName
IF.addNode2TreeStore treeStore (fromJust nodeData) child
putMVar mvarGUI guiData{folderTreeMVarGUIData = treeStore}
activateWithEditor mvarGUI cmdDat Nothing (IF.getPathFromNodeData child) 1
where
getFileTreeNodeData :: Maybe IF.NodeData -> Maybe String -> Maybe IF.NodeData
getFileTreeNodeData (Just (IF.FolderNodeData modName _ path)) (Just name) =
Just $ IF.FileNodeData (getModName modName (snd (normName name))) (""++(fst (normName name))++"") (path > (fst (normName name)))
getFileTreeNodeData _ _ = Nothing
normName name
| L.isSuffixOf _HS_FILE_EXT name = (name, takeBaseName name)
| otherwise = (name++_HS_FILE_EXT, name)
getModName :: String -> String -> String
getModName parent child
| null parent = child
| otherwise = parent ++ "." ++ child
tpl = ["{-# LANGUAGE GADTs #-}"
,"{-# LANGUAGE LambdaCase #-}"
,"{-# LANGUAGE MultiWayIf #-}"
,"{-# LANGUAGE BinaryLiterals #-}"
,"{-# LANGUAGE TemplateHaskell #-}"
,"{-# LANGUAGE OverloadedStrings #-}"
,"{-# LANGUAGE ScopedTypeVariables #-}"
,"{-# LANGUAGE DeriveDataTypeable #-}"
,""
,"module $MODULE$ where"
,""
]
code modName =
TPL.toString
$ TPL.setManyAttrib [("MODULE", modName)]
$ TPL.newSTMP $ unlines tpl
-- |
-- Event Handler
--
folderTreeRenameAction :: MVar MVarGUIData -> IF.FolderTreeRenameAction
folderTreeRenameAction mvarGUI = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
_ <- IF.getSelectedFolderTreeNodeData builder treeStore
nameMay <- IF.getNameByFolderTreeDialog builder "Rename" "Input name." "" True
infoM _LOG_NAME $ "[folderTreeRenameAction] not yet implemented. " ++ show nameMay
-- |
-- Event Handler
--
folderTreeDeleteAction :: MVar MVarGUIData -> IF.FolderTreeDeleteAction
folderTreeDeleteAction mvarGUI = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
IF.getSelectedFolderTreeNodeData builder treeStore >>= \case
Nothing -> errorM _LOG_NAME $ "invalid node data."
Just nodeDat -> do
let name = IF.getNameFromNodeData nodeDat
nameMay <- IF.getNameByFolderTreeDialog builder "Delete" ("Delete " ++ name) name False
infoM _LOG_NAME $ "[folderTreeDeleteAction] not yet implemented. " ++ show nameMay
-- |
-- Event Handler
--
folderTreeSearchAction :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeSearchAction
folderTreeSearchAction mvarGUI cmdDat = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
IF.getSelectedFolderTreeNodeData builder treeStore >>= \case
Nothing -> errorM _LOG_NAME "invalid tree folder status."
Just (IF.FolderNodeData _ _ _) -> IF.getSelectedFolderTreeAllNodeData builder treeStore >>= withNodeDatas builder
Just (IF.FileNodeData _ _ _) -> do
folderTreeKeyPressEventHandler mvarGUI cmdDat "Return" False False
mainWindowKeyPressEventHandler mvarGUI cmdDat "f" False True
return ()
where
withNodeDatas _ [] = errorM _LOG_NAME "invalid node data."
withNodeDatas builder nodeDatas = do
(keyMay, isLower) <- IF.getSearchKeyBySearchDialog builder ""
when (isJust keyMay) $ do
runSearch mvarGUI cmdDat nodeDatas (fromJust keyMay, isLower)
-- |
-- Event Handler
--
folderTreeReplaceAction :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeReplaceAction
folderTreeReplaceAction mvarGUI cmdDat = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
IF.getSelectedFolderTreeNodeData builder treeStore >>= \case
Nothing -> errorM _LOG_NAME "invalid tree folder status."
Just (IF.FolderNodeData _ _ _) -> IF.getSelectedFolderTreeAllNodeData builder treeStore >>= withNodeDatas builder
Just (IF.FileNodeData _ _ _) -> do
folderTreeKeyPressEventHandler mvarGUI cmdDat "Return" False False
mainWindowKeyPressEventHandler mvarGUI cmdDat "r" False True
return ()
where
withNodeDatas _ [] = errorM _LOG_NAME "invalid node data."
withNodeDatas builder nodeDatas = do
IF.getReplaceByReplaceDialog builder "ALL" >>= \case
Nothing -> return ()
Just (key, rep) -> do
saveAll mvarGUI cmdDat
replaceFiles nodeDatas Nothing key rep
reloadAll mvarGUI
runSearch mvarGUI cmdDat nodeDatas (rep, False)
-- |
-- イベントハンドラ
--
folderTreeKeyPressEventHandler :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeKeyPressEventHandler
folderTreeKeyPressEventHandler mvarGUI _ "Right" _ _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
IF.expandFolderTree builder store
return True
folderTreeKeyPressEventHandler mvarGUI _ "Left" _ _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
IF.collapseFolderTree builder store
return True
folderTreeKeyPressEventHandler mvarGUI cmdDat "Return" _ _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
nodeMay <- IF.getSelectedFolderTreeNodeData builder store
case nodeMay of
Just (IF.FolderNodeData _ _ _) -> do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
IF.expandCollapseFolderTree builder store
putMVar mvarGUI guiData
Just (IF.FileNodeData _ _ path) -> do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path (-1)
Nothing -> errorM _LOG_NAME $ "invalid tree node"
return True
folderTreeKeyPressEventHandler _ _ _ _ _ = return False
-- |
-- Event Handler
--
folderTreeStartupAction :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeStartupAction
folderTreeStartupAction mvarGUI _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
curStartupDat = startupNodeDataMVarGUIData guiData
IF.getSelectedFolderTreeNodeData builder store >>= \case
Nothing -> errorM _LOG_NAME "[folderTreeStartupAction]invalid node data."
Just nodeDat -> do
when (isJust curStartupDat) $ IF.updateTreeNode store (fromJust curStartupDat) $ IF.changeNameColorOfNodeData (fromJust curStartupDat) _STARTUP_MODULE_COLOR_BLUE _STARTUP_MODULE_COLOR_BLACK
let newDat = IF.changeNameColorOfNodeData nodeDat _STARTUP_MODULE_COLOR_BLACK _STARTUP_MODULE_COLOR_BLUE
IF.updateTreeNode store nodeDat newDat
guiData <- takeMVar mvarGUI
putMVar mvarGUI guiData {startupNodeDataMVarGUIData = Just newDat}
-- |=====================================================================
-- ConsoleViewのイベントハンドラ
--
-- |
--
--
consoleDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.ConsoleDoubleClickedHandler
consoleDoubleClickedHandler mvarGUI cmdData str = do
case getActivatePosFromLine str of
Nothing -> infoM _LOG_NAME $ "code highlight rage not found." ++ str
Just pos -> activateTextEditor mvarGUI cmdData pos
-- |=====================================================================
-- BreakPointTableのイベントハンドラ
--
-- |
--
--
breakPointTableDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.BreakPointTableDoubleClickedHandler
breakPointTableDoubleClickedHandler mvarGUI cmdDat (IF.BreakPointData _ path lineNo _ _) = do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path lineNo
-- |=====================================================================
-- BindingTableのイベントハンドラ
--
-- |
--
--
bindingTableDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.BindingTableDoubleClickedHandler
bindingTableDoubleClickedHandler mvarGUI cmdData (IF.BindingData argName _ _) = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
bindStore = bindingListStoreMVarGUIData guiData
forceVar = forceDebugCommandData cmdData
bindings = bindingsDebugCommandData cmdData
getResult = readDebugCommandData cmdData
putMVar mvarGUI guiData
cmdStr <- forceVar argName
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
_ <- bindings
bindStr <- getResult
case getBindingDataList bindStr of
Left err -> errorM _LOG_NAME $ show err
Right dats -> IF.updateBindingTable bindStore dats
-- |=====================================================================
-- TraceTableのイベントハンドラ
--
-- |
--
--
traceTableDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.TraceTableDoubleClickedHandler
traceTableDoubleClickedHandler mvarGUI cmdData (IF.TraceData traceIdStr _ filePath) = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
bindings = bindingsDebugCommandData cmdData
curTraceId = traceIdMVarGUIData guiData
traceId = (read traceIdStr) :: Int
moveCount = curTraceId - traceId
getResult = readDebugCommandData cmdData
bindStore = bindingListStoreMVarGUIData guiData
traceCmd = if 0 > moveCount then traceForwardDebugCommandData cmdData
else traceBackDebugCommandData cmdData
putMVar mvarGUI guiData {traceIdMVarGUIData = traceId}
res <- foldM (go builder traceCmd getResult) (""::String) [1..(abs moveCount)]
let path = strip $ replace "Logged breakpoint at " "" $ head $ lines res
when (filePath /= path) $ warningM _LOG_NAME $ "move trace failed." ++ res
_ <- bindings
bindStr <- getResult
case getBindingDataList bindStr of
Left err -> errorM _LOG_NAME $ show err
Right dats -> IF.updateBindingTable bindStore dats
case getHighlightTextRangeData filePath of
Left err -> errorM _LOG_NAME $ show err
Right pos -> activateTextEditor mvarGUI cmdData pos
where
go builder traceCmd getResult _ _ = do
cmdStr <- traceCmd
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
return cmdStr
-- |=====================================================================
-- SearchResultTableのイベントハンドラ
--
-- |
--
--
searchResultTableDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.SearchResultTableDoubleClickedHandler
searchResultTableDoubleClickedHandler mvarGUI cmdData (IF.SearchResultData filePath lineNo startCol endCol _) = do
let pos = HighlightTextRangeData {
filePathHighlightTextRangeData = filePath
, startLineNoHighlightTextRangeData = lineNo
, startColNoHighlightTextRangeData = startCol
, endLineNoHighlightTextRangeData = lineNo
, endColNoHighlightTextRangeData = endCol
}
activateTextEditor mvarGUI cmdData pos
-- |=====================================================================
-- activateWithEditorで登録するイベントハンドラ
--
-- |
-- Event Handler
--
codeNoteCloseEventHanlder :: MVar MVarGUIData -> IF.CodeNoteCloseEventHandler
codeNoteCloseEventHanlder mvarGUI textEditor = do
guiData <- takeMVar mvarGUI
let noteMap = codeNoteMapMVarGUIData guiData
let delKeys = Map.foldWithKey (\k v acc -> if textEditor == v then k:acc else acc) [] noteMap
let newMap = foldr Map.delete noteMap delKeys
putMVar mvarGUI $ guiData {codeNoteMapMVarGUIData = newMap}
-- |
-- Event Handler
--
lineTextDoubleClickedHandler :: MVar MVarGUIData -> DebugCommandData -> IF.LineTextDoubleClickedHandler
lineTextDoubleClickedHandler mvarGUI cmdData False lineNo = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[lineTextDoubleClickedHandler] invalid text editor."
Just a -> withEditor a
where
withEditor (nodeDat, editor) = do
IF.updateBreakPointTag editor False lineNo
let bpDat = IF.BreakPointData (IF.getModNameFromNodeData nodeDat) (IF.getPathFromNodeData nodeDat) (lineNo+1) Nothing ""
addBreakPointOnBPTable mvarGUI bpDat
addBreakPointOnCUI mvarGUI cmdData bpDat
lineTextDoubleClickedHandler mvarGUI cmdData True lineNo = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[lineTextDoubleClickedHandler] invalid text editor."
Just a -> withEditor a
where
withEditor (nodeDat, editor) = do
IF.updateBreakPointTag editor True lineNo
let bpKey = (IF.getPathFromNodeData nodeDat, lineNo+1)
deleteBreakPointOnCUI mvarGUI cmdData bpKey
deleteBreakPointOnBPTable mvarGUI bpKey
-- |
--
--
codeTextKeyPressEventHandler :: MVar MVarGUIData -> DebugCommandData -> IF.CodeTextKeyPressEventHandler
codeTextKeyPressEventHandler mvarGUI cmdData "F9" False False True lineNo = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeTextKeyPressEventHandler] invalid text editor" >> return True
Just a -> withEditor a
where
withEditor (nodeDat, editor) = do
IF.updateBreakPointTag editor True lineNo
let bpKey = (IF.getPathFromNodeData nodeDat, lineNo+1)
deleteBreakPointOnCUI mvarGUI cmdData bpKey
deleteBreakPointOnBPTable mvarGUI bpKey
return True
codeTextKeyPressEventHandler mvarGUI cmdData "F9" False False False lineNo = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeTextKeyPressEventHandler] invalid text editor" >> return True
Just a -> withEditor a
where
withEditor (nodeDat, editor) = do
IF.updateBreakPointTag editor False lineNo
let bpDat = IF.BreakPointData (IF.getModNameFromNodeData nodeDat) (IF.getPathFromNodeData nodeDat) (lineNo+1) Nothing ""
addBreakPointOnBPTable mvarGUI bpDat
addBreakPointOnCUI mvarGUI cmdData bpDat
return True
codeTextKeyPressEventHandler mvarGUI _ "Right" False True _ _ = do
toolBTindentHandler mvarGUI
return True
codeTextKeyPressEventHandler mvarGUI _ "Left" False True _ _ = do
toolBTunIndentHandler mvarGUI
return True
codeTextKeyPressEventHandler _ _ "g" False True _ _ = do
infoM _LOG_NAME "ctrl g called. not yet implemented."
return True
codeTextKeyPressEventHandler mvarGUI cmdData "F4" _ _ _ _ = jumpToCodeDefinition mvarGUI cmdData >> return True
codeTextKeyPressEventHandler mvarGUI cmdData "F12" _ _ _ _ = jumpToCodeDefinition mvarGUI cmdData >> return True
codeTextKeyPressEventHandler mvarGUI cmdDat "z" False True _ _ = do
guiData <- takeMVar mvarGUI
let buf = undoBufferMVarGUIData guiData
itemMay <- case buf of
[] -> putMVar mvarGUI guiData >> return Nothing
x:xs -> do
putMVar mvarGUI guiData{ undoBufferMVarGUIData = xs
, redoBufferMVarGUIData = x:redoBufferMVarGUIData guiData
, unDoReDoFlagMVarGUIData = True}
return $ Just x
unDo mvarGUI cmdDat itemMay
guiData <- takeMVar mvarGUI
putMVar mvarGUI guiData{unDoReDoFlagMVarGUIData = False}
return True
where
unDo :: MVar MVarGUIData -> DebugCommandData -> Maybe UndoRedoData -> IO ()
unDo _ _ Nothing = return ()
unDo mvarGUI cmdDat (Just (DeleteRangeUndoRedoData path startLineNo startColNo _ _ str)) = do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path startLineNo
findTextEditorByPath mvarGUI path >>= \case
Nothing -> errorM _LOG_NAME $ "invalie note."
Just editor -> do
IF.insertText2TextEditor editor startLineNo startColNo str
IF.setCursorOnTextEditor editor startLineNo startColNo
unDo mvarGUI cmdDat (Just (InsertTextUndoRedoData path startLineNo startColNo str)) = do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path startLineNo
findTextEditorByPath mvarGUI path >>= \case
Nothing -> errorM _LOG_NAME $ "invalie note."
Just editor -> do
(endLineNo, endColNo) <- IF.searchEndIter editor startLineNo startColNo str
IF.deleteRangeOnTextEditor editor startLineNo startColNo endLineNo endColNo
IF.setCursorOnTextEditor editor startLineNo startColNo
codeTextKeyPressEventHandler mvarGUI cmdDat "y" False True _ _ = do
guiData <- takeMVar mvarGUI
let buf = redoBufferMVarGUIData guiData
itemMay <- case buf of
[] -> putMVar mvarGUI guiData >> return Nothing
x:xs -> do
putMVar mvarGUI guiData{ redoBufferMVarGUIData = xs
, unDoReDoFlagMVarGUIData = True}
return $ Just x
reDo mvarGUI cmdDat itemMay
guiData <- takeMVar mvarGUI
putMVar mvarGUI guiData{unDoReDoFlagMVarGUIData = False}
return True
where
reDo :: MVar MVarGUIData -> DebugCommandData -> Maybe UndoRedoData -> IO ()
reDo _ _ Nothing = return ()
reDo mvarGUI cmdDat (Just (DeleteRangeUndoRedoData path startLineNo startColNo _ _ str)) = do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path startLineNo
findTextEditorByPath mvarGUI path >>= \case
Nothing -> errorM _LOG_NAME $ "[reDo]invalie note."
Just editor -> do
(endLineNo, endColNo) <- IF.searchEndIter editor startLineNo startColNo str
IF.deleteRangeOnTextEditor editor startLineNo startColNo endLineNo endColNo
IF.setCursorOnTextEditor editor startLineNo startColNo
return ()
reDo mvarGUI cmdDat (Just (InsertTextUndoRedoData path startLineNo startColNo str)) = do
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path startLineNo
findTextEditorByPath mvarGUI path >>= \case
Nothing -> errorM _LOG_NAME $ "[reDo] invalie note."
Just editor -> do
IF.insertText2TextEditor editor startLineNo startColNo str
(endLineNo, endColNo) <- IF.searchEndIter editor startLineNo startColNo str
IF.setCursorOnTextEditor editor endLineNo endColNo
return ()
codeTextKeyPressEventHandler mvarGUI cmdDat "Page_Up" False True _ _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.pageUpTextEditor builder
return True
codeTextKeyPressEventHandler mvarGUI cmdDat "Page_Down" False True _ _ = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.pageDownTextEditor builder
return True
codeTextKeyPressEventHandler _ _ _ _ _ _ _ = return False
-- |
--
--
jumpToCodeDefinition :: MVar MVarGUIData -> DebugCommandData -> IO ()
jumpToCodeDefinition mvarGUI cmdData = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeTextKeyPressEventHandler] invalid text editor."
Just a -> withEditor a
where
withEditor (nodeDat, editor) = do
key <- IF.getSelectedText editor
withKey key $ IF.getPathFromNodeData nodeDat
withKey key path
| null key = return ()
| otherwise = autoRunGHCi mvarGUI cmdData >>= \case
False -> errorM _LOG_NAME "run ghci failed."
True -> do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
res <- IF.isDebugStarted builder
debugStarted key path res
debugStarted key path True = fileLoaded key path True
debugStarted key path False = loadHsFile mvarGUI cmdData path >>= fileLoaded key path
fileLoaded _ path False = errorM _LOG_NAME ("load hs file fail." ++ path)
fileLoaded key _ True = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
info = infoDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- info key
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
case getDefinedTextRangeData cmdStr of
Right pos -> activateTextEditor mvarGUI cmdData pos
Left err -> infoM _LOG_NAME $ "[codeTextKeyPressEventHandler]" ++ show err
-- |
-- イベントハンドラ
--
codeBufferChangedEventHandler :: MVar MVarGUIData -> IO ()
codeBufferChangedEventHandler mvarGUI = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeBufferChangedEventHandler] invalid text editor."
Just (_, editor) -> do
IF.clearSearchResultTag editor
clearSearchResultTable mvarGUI
setSearchFiles mvarGUI []
-- |
-- イベントハンドラ
--
codeBufferDeleteRangeEventHandler :: MVar MVarGUIData -> (Int, Int) -> (Int, Int) -> String -> IO ()
codeBufferDeleteRangeEventHandler mvarGUI (siLineNo, siColNo) (eiLineNo, eiColNo) str = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeBufferDeleteRangeEventHandler] invalid text editor."
Just a -> withEditor a
where
withEditor (nodeDat, _) = do
guiData <- takeMVar mvarGUI
let unDoBuf = undoBufferMVarGUIData guiData
reDoBuf = redoBufferMVarGUIData guiData
doing = unDoReDoFlagMVarGUIData guiData
let delDat = DeleteRangeUndoRedoData {
filePathDeleteRangeUndoRedoData = IF.getPathFromNodeData nodeDat
, startLineNoDeleteRangeUndoRedoData = siLineNo
, startColNoDeleteRangeUndoRedoData = siColNo
, endLineNoDeleteRangeUndoRedoData = eiLineNo
, endColNoDeleteRangeUndoRedoData = eiColNo
, textDeleteRangeUndoRedoData = str
}
let newUndoBuf = if doing then unDoBuf
else pushWithLimit unDoBuf delDat _UNDO_BUFFER_MAX_SIZE
let newRedoBuf = if doing then reDoBuf else []
putMVar mvarGUI guiData{ undoBufferMVarGUIData = newUndoBuf
, redoBufferMVarGUIData = newRedoBuf}
-- |
-- イベントハンドラ
--
codeBufferInsertTextEventHandler :: MVar MVarGUIData -> (Int, Int) -> String -> IO ()
codeBufferInsertTextEventHandler mvarGUI (siLineNo, siColNo) str = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeBufferInsertTextEventHandler] invalid text editor."
Just a -> withEditor a
where
withEditor (nodeDat, _) = do
guiData <- takeMVar mvarGUI
let unDoBuf = undoBufferMVarGUIData guiData
reDoBuf = redoBufferMVarGUIData guiData
doing = unDoReDoFlagMVarGUIData guiData
let insertDat = InsertTextUndoRedoData {
filePathInsertTextUndoRedoData = IF.getPathFromNodeData nodeDat
, startLineNoInsertTextUndoRedoData = siLineNo
, startColNoInsertTextUndoRedoData = siColNo
, textInsertTextUndoRedoData = str
}
let newUndoBuf = if doing then unDoBuf
else pushWithLimit unDoBuf insertDat _UNDO_BUFFER_MAX_SIZE
let newRedoBuf = if doing then reDoBuf else []
putMVar mvarGUI guiData{ undoBufferMVarGUIData = newUndoBuf
, redoBufferMVarGUIData = newRedoBuf}
-- |=====================================================================
-- Utility
-- パーサ
-- |
-- コンソールに表示される文字列において、コードハイライトが可能な位置を
-- 抽出するパーサ
--
getActivatePosFromLine :: String -> Maybe HighlightTextRangeData
getActivatePosFromLine res = go $ split " " res
where
go [] = Nothing
go (x:xs) = case parse parseHighlightTextRange "getActivatePosFromLine" x of
Left _ -> go xs
Right bp -> Just bp
-- |
--
--
getHighlightTextRangeData :: String -> Either ParseError HighlightTextRangeData
getHighlightTextRangeData = parse parseHighlightTextRange "getHighlightTextRangeData"
-- |
--
--
getStoppedTextRangeData :: String -> Either ParseError HighlightTextRangeData
getStoppedTextRangeData = parse parser "getStoppedTextRangeData"
where
parser = do
_ <- manyTill anyChar (try (string "Stopped at "))
parseHighlightTextRange
-- |
--
--
getDefinedTextRangeData :: String -> Either ParseError HighlightTextRangeData
getDefinedTextRangeData = parse parser "getDefinedTextRangeData"
where
parser = do
_ <- manyTill anyChar (try (string "Defined at "))
parseHighlightTextRange
-- |
-- parser of
-- A) src\Phoityne\IO\Main.hs:31:11-14
-- B) src\Main.hs:(17,3)-(19,35)
-- C) src\Phoityne\IO\Main.hs:31:11
-- src\Phoityne\IO\Main.hs:31:11:
--
parseHighlightTextRange :: forall u. ParsecT String u Identity HighlightTextRangeData
parseHighlightTextRange = do
path <- manyTill anyChar (string (_HS_FILE_EXT ++ ":"))
(sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC
return $ HighlightTextRangeData (path ++ _HS_FILE_EXT) sl sn el en
where
parseA = do
ln <- manyTill digit (char ':')
sn <- manyTill digit (char '-')
en <- try (manyTill digit endOfLine) <|> try (manyTill digit eof)
return ((read ln), (read sn), (read ln), (read en))
parseB = do
_ <- char '('
sl <- manyTill digit (char ',')
sn <- manyTill digit (char ')')
_ <- string "-("
el <- manyTill digit (char ',')
en <- manyTill digit (char ')')
return ((read sl), (read sn), (read el), (read en))
parseC = do
ln <- manyTill digit (char ':')
sn <- try (manyTill digit (char ':')) <|> try (manyTill digit endOfLine) <|> try (manyTill digit eof)
return ((read ln), (read sn), (read ln), (read sn))
-- |
-- バインディング値のパーサ
--
-- parser of
-- args :: Project.Argument.ArgData = _
-- _result :: IO Data.ConfigFile.Types.ConfigParser = _
--
getBindingDataList :: String -> Either ParseError [IF.BindingData]
getBindingDataList res = parse parser "getBindingDataList" res
where
parser = manyTill parser1 (string _PHOITYNE_GHCI_PROMPT)
parser1 = do
varName <- manyTill anyChar (string "::")
modName <- manyTill anyChar (try (string "="))
valStr <- manyTill anyChar lineSep <|> manyTill anyChar eof
return $ IF.BindingData (strip varName) (strip modName) valStr
lineSep = try $ endOfLine >> notFollowedBy space
-- |
-- トレース情報のパーサ
--
-- parser of
-- Phoityne>>= :history
-- -1 : config:confB (src\Project\Argument.hs:85:17-28)
-- -2 : config:confB (src\Project\Argument.hs:87:17-36)
-- src\Project\IO\Main.hs:(70,9)-(71,65)
--
getTraceDataList :: String -> Either ParseError [IF.TraceData]
getTraceDataList res = go [] $ reverse $ filter (L.isPrefixOf "-") $ lines res
where
go acc [] = Right acc
go acc (x:xs) = case parse parser "getTraceDataList" x of
Left err -> Left err
Right dat -> go (dat:acc) xs
parser = do
traceId <- manyTill anyChar (many1 space >> char ':' >> space)
funcName <- manyTill anyChar (space >> char '(')
filePath <- manyTill anyChar eof
return $ IF.TraceData (strip traceId) funcName (init (strip filePath))
-- |=====================================================================
-- Utility
-- 検索
--
runSearch :: MVar MVarGUIData -> DebugCommandData -> [IF.NodeData] -> (String, Bool) -> IO ()
runSearch mvarGUI cmdDat targets info@(key, isLower) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
clearSearchResultTable mvarGUI
setSearchFiles mvarGUI targets
saveAll mvarGUI cmdDat
keywordLineSearch targets info (searchResultHandler mvarGUI)
activateSearchResultTab mvarGUI
-- |
-- F3が押された際に、検索キーが設定されているが、検索未実施のソースファイルが
-- テキストエディッタに表示されている場合に、検索を自動実行する。
--
autoSearch :: MVar MVarGUIData -> DebugCommandData -> IO ()
autoSearch mvarGUI cmdDat = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[autoSearch] invalid text editor"
Just a -> withEditor a
where
withEditor curEditor@(nodeDat, _) = do
guiData <- readMVar mvarGUI
let files = searchFilesMVarGUIData guiData
hasSearched curEditor $ L.elem (IF.getPathFromNodeData nodeDat) files
hasSearched _ True = return ()
hasSearched curEditor False = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
key <- IF.getSearchKeyFromSearchDialog builder
isSearchKey curEditor key
isSearchKey (nodeData, editor) info@(key, _)
| null key = mainWindowKeyPressEventHandler mvarGUI cmdDat "f" False True >> return ()
| otherwise = do
runSearch mvarGUI cmdDat [nodeData] info
updateSearchResultTag mvarGUI cmdDat (IF.getPathFromNodeData nodeData) editor
-- |
-- 検索対象となったファイル群を共有データに保存する。
--
setSearchFiles :: MVar MVarGUIData -> [IF.NodeData] -> IO ()
setSearchFiles mvarGUI datas = do
let paths = foldr (\d acc->IF.getPathFromNodeData d : acc) [] datas
guiData <- takeMVar mvarGUI
putMVar mvarGUI guiData { searchFilesMVarGUIData = paths }
-- |
-- 検索結果の削除
--
clearSearchResultTable :: MVar MVarGUIData -> IO ()
clearSearchResultTable mvarGUI = do
guiData <- takeMVar mvarGUI
let store = searchResultListStoreMVarGUIData guiData
IF.clearSearchResultTable store
putMVar mvarGUI guiData{searchResultListStoreMVarGUIData = store}
-- |
-- 検索結果テーブルにフォーカスをあてる。
--
activateSearchResultTab :: MVar MVarGUIData -> IO ()
activateSearchResultTab mvarGUI = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.activateSearchResultTab builder
-- |
-- 複数ファイルにおいて、行単位のキーワード検索を行う
--
keywordLineSearch :: [IF.NodeData] -> (String, Bool) -> (FilePath -> Int -> Int -> Int -> String -> IO ()) -> IO ()
keywordLineSearch [] _ _ = return ()
keywordLineSearch ((IF.FolderNodeData _ _ _):xs) key hdl = keywordLineSearch xs key hdl
keywordLineSearch ((IF.FileNodeData _ _ path):xs) key hdl = searchFile path key hdl >> keywordLineSearch xs key hdl
where
-- |
--
--
searchFile :: FilePath -> (String, Bool) -> (FilePath -> Int -> Int -> Int -> String -> IO ()) -> IO ()
searchFile path (key, isLower) hdl = do
bs <- loadFile path
searchLine (TE.pack key) isLower (hdl path) 1 $ TE.lines $ TE.decodeUtf8 bs
-- |
--
--
searchLine :: TE.Text -> Bool -> (Int -> Int -> Int -> String -> IO ()) -> Int -> [TE.Text] -> IO ()
searchLine _ _ _ _ [] = return ()
searchLine key isLower hdl lineNo (line:lines) = do
mapM_ go $ TE.breakOnAll (if isLower then TE.toLower key else key) (if isLower then TE.toLower line else line)
searchLine key isLower hdl (lineNo+1) lines
where
go (prior, _) = hdl lineNo (colIdx prior) (colIdx prior + TE.length key - 1) (TE.unpack line)
colIdx txt = (TE.length txt) + 1
-- |
-- 検索中にヒットした情報をストアに保存するハンドラ
--
searchResultHandler :: MVar MVarGUIData -> FilePath -> Int -> Int -> Int -> String -> IO ()
searchResultHandler mvarGUI filePath lineNo startColNo endColNo line = do
guiData <- takeMVar mvarGUI
let store = searchResultListStoreMVarGUIData guiData
IF.addSearchReslutTable store $ IF.SearchResultData filePath lineNo startColNo endColNo (strip line)
putMVar mvarGUI guiData{searchResultListStoreMVarGUIData = store}
-- |
-- 行単位の置換を行う
--
replaceFiles :: [IF.NodeData] -> Maybe (Int, Int) -> String -> String -> IO ()
replaceFiles [] _ _ _ = return ()
replaceFiles ((IF.FolderNodeData _ _ _):xs) rangeMay key rep = replaceFiles xs rangeMay key rep
replaceFiles ((IF.FileNodeData _ _ path):xs) rangeMay key rep = replaceFile path rangeMay key rep >> replaceFiles xs rangeMay key rep
where
replaceFile :: FilePath -> Maybe (Int, Int) -> String -> String -> IO ()
replaceFile path Nothing key rep = do
bs <- loadFile path
let res = TE.replace (TE.pack key) (TE.pack rep) $ TE.decodeUtf8 bs
saveFile path $ TE.encodeUtf8 res
replaceFile path (Just (sl, el)) key rep = do
bs <- loadFile path
let conts = TE.lines . TE.decodeUtf8 $ bs
prefix = TE.unlines$ take sl conts
targets = take (el - sl + 1) $ drop sl conts
suffix = TE.unlines $ drop (el+1) conts
repls = TE.replace (TE.pack key) (TE.pack rep) $ TE.unlines targets
res = TE.append prefix $ TE.append repls suffix
saveFile path $ TE.encodeUtf8 res
-- |=====================================================================
-- Utility
-- デバッグ
--
-- |
-- ブレークポイントテーブルからブレークポイントを削除する
--
deleteBreakPointOnBPTable :: MVar MVarGUIData -> IF.BreakPointDataKey -> IO ()
deleteBreakPointOnBPTable mvarGUI bpKey = do
guiData <- readMVar mvarGUI
let bpList = breakPointListMVarGUIData guiData
IF.deleteFromBreakPointListStore bpList bpKey
-- |
-- ブレークポイントをGHCi上でdeleteする
--
deleteBreakPointOnCUI :: MVar MVarGUIData -> DebugCommandData -> IF.BreakPointDataKey -> IO ()
deleteBreakPointOnCUI mvarGUI cmdData bpKey@(path, lineNo) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
isDebug <- IF.isDebugStarted builder
when isDebug deleteBreakPointOnCUIInternal
where
deleteBreakPointOnCUIInternal = do
guiData <- readMVar mvarGUI
let bpList = breakPointListMVarGUIData guiData
IF.findBreakPointData bpList bpKey >>= deleteBreakPointByBPData
deleteBreakPointByBPData (Just (IF.BreakPointData _ _ _ (Just breakNo) _)) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
deleteBreak = deleteBreakDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- deleteBreak breakNo
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
deleteBreakPointByBPData _ = errorM _LOG_NAME $ "invalid delete break point." ++ path ++ ":" ++ show lineNo
-- |
-- ブレークポイントテーブルにブレークポイントを追加する
--
addBreakPointOnBPTable :: MVar MVarGUIData -> IF.BreakPointData -> IO ()
addBreakPointOnBPTable mvarGUI bpDat = do
guiData <- readMVar mvarGUI
let bpList = breakPointListMVarGUIData guiData
IF.addBreakPoint2Table bpList bpDat
-- |
-- GHCi上でブレークポイントを追加する
--
addBreakPointOnCUI :: MVar MVarGUIData -> DebugCommandData -> IF.BreakPointData -> IO ()
addBreakPointOnCUI mvarGUI cmdData breakData@(IF.BreakPointData modName path lineNo _ _) = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
IF.isDebugStarted builder >>= \case
False -> return ()
True -> addBreakPointInternl
where
addBreakPointInternl = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
setBreak = breakDebugCommandData cmdData
getResult = readDebugCommandData cmdData
cmdStr <- setBreak modName lineNo
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
case getBreakPointNo cmdStr of
Left err -> if L.isPrefixOf _NO_BREAK_POINT_LOCATION cmdStr then deleteBreakPoint
else errorM _LOG_NAME $ "unexpected break set result. " ++ show err ++ cmdStr
Right no -> updateBreakPointNo no
deleteBreakPoint = do
guiData <- readMVar mvarGUI
let breakStore = breakPointListMVarGUIData guiData
codeNoteMap = codeNoteMapMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
nodeMay <- IF.findTreeNode treeStore
(\node -> L.isSuffixOf path (IF.getPathFromNodeData node))
case nodeMay of
Nothing -> errorM _LOG_NAME $ "node data not found." ++ show breakData
Just node -> do
IF.deleteFromBreakPointListStore breakStore (path, lineNo)
case Map.lookup node codeNoteMap of
Nothing -> return ()
Just editor -> IF.deleteBreakPointTag editor (IF.lineNoBreakPointData breakData)
updateBreakPointNo no = do
guiData <- readMVar mvarGUI
let bpList = breakPointListMVarGUIData guiData
key = (path, lineNo)
IF.updateBreakPointTable bpList key breakData{ IF.breakNoBreakPointData = Just no }
-- |
-- parser of
-- Breakpoint 0 activated at src\Main.hs:(21,3)-(23,35)
--
getBreakPointNo :: String -> Either ParseError Int
getBreakPointNo res = parse parser "getBreakPointNo" res
where
parser = do
_ <- manyTill anyChar (string "Breakpoint ")
no <- manyTill digit (string " activated at")
return $ read no
-- |
--
--
deleteBreakPointTag :: MVar MVarGUIData -> IF.BreakPointDataKey -> IO ()
deleteBreakPointTag mvarGUI (path, lineNo) = findTextEditorByPath mvarGUI path >>= withEditor
where
withEditor Nothing = return ()
withEditor (Just (IF.TextEditorData lineView _ _ _)) = IF.deleteBreakPointTagAtLine lineView (lineNo - 1)
-- |=====================================================================
-- Utility
-- テキストエディッタ
--
-- |
--
--
activateTextEditor :: MVar MVarGUIData -> DebugCommandData -> HighlightTextRangeData -> IO ()
activateTextEditor mvarGUI cmdDat pos = do
let path = filePathHighlightTextRangeData pos
lineNo = startLineNoHighlightTextRangeData pos
editorMay <- findTextEditorByPath mvarGUI path
activateWithEditor mvarGUI cmdDat editorMay path lineNo
editorMay <- findTextEditorByPath mvarGUI path
highLightBreakPoint mvarGUI pos editorMay
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
breakStore = breakPointListMVarGUIData guiData
IF.highLightBreakPointTableRow builder breakStore ((filePathHighlightTextRangeData pos), (startLineNoHighlightTextRangeData pos))
where
highLightBreakPoint _ _ Nothing = errorM _LOG_NAME $ "[highLightBreakPoint]invalid node map."
highLightBreakPoint _ pos (Just textEditor) = do
--guiData <- readMVar mvarGUI
--let codeNoteMap = codeNoteMapMVarGUIData guiData
--mapM_ IF.offLightBreakPoint $ Map.elems codeNoteMap
IF.highLightBreakPoint textEditor
(startLineNoHighlightTextRangeData pos)
(startColNoHighlightTextRangeData pos)
(endLineNoHighlightTextRangeData pos)
(endColNoHighlightTextRangeData pos)
-- |
--
--
activateWithEditor :: MVar MVarGUIData -> DebugCommandData -> Maybe IF.TextEditorData -> FilePath -> Int -> IO ()
activateWithEditor mvarGUI _ (Just editor) _ lineNo = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
putMVar mvarGUI guiData
IF.activateCodeNote builder editor lineNo
activateWithEditor mvarGUI cmdDat Nothing filePath lineNo = do
createCodeNode mvarGUI filePath lineNo
setupBreakPointTags mvarGUI filePath
where
setupBreakPointTags mvarGUI path = findTextEditorByPath mvarGUI path >>= \case
Nothing -> errorM _LOG_NAME $ "[setupBreakPointTags]invalid node map."
Just (IF.TextEditorData lineView _ _ _) -> do
guiData <- takeMVar mvarGUI
let listStore = breakPointListMVarGUIData guiData
breaks <- IF.getBreakPointList listStore
mapM_ (addBreakPointTag lineView) $ filter (\(IF.BreakPointData _ filePath _ _ _)->L.isSuffixOf path filePath) breaks
putMVar mvarGUI guiData
addBreakPointTag lineView (IF.BreakPointData _ _ lineNo _ _) =
IF.addBreakPointTagAtLine lineView (lineNo-1)
createCodeNode mvarGUI path lineNo = do
guiData <- takeMVar mvarGUI
let treeStore = folderTreeMVarGUIData guiData
nodeMay <- IF.findTreeNode treeStore (\node -> L.isSuffixOf path (IF.getPathFromNodeData node))
putMVar mvarGUI guiData
createCodeNodeWithNodeMay mvarGUI lineNo nodeMay
createCodeNodeWithNodeMay _ _ Nothing = errorM _LOG_NAME $ "[createCodeNodeWithNodeMay]unexpected error."
createCodeNodeWithNodeMay mvarGUI lineNo (Just node) = createCodeNodeWithNode mvarGUI lineNo node
createCodeNodeWithNode _ _ (IF.FolderNodeData _ _ _) = errorM _LOG_NAME $ "[createCodeNodeWithNode]unexpected error."
createCodeNodeWithNode mvarGUI lineNo node@(IF.FileNodeData _ _ path) = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
codeNoteMap = codeNoteMapMVarGUIData guiData
code <- loadFile path
wid <- IF.setupCodeNote builder (takeFileName path) path code
(codeNoteCloseEventHanlder mvarGUI)
(lineTextDoubleClickedHandler mvarGUI cmdDat)
(Just lineNo)
(codeTextKeyPressEventHandler mvarGUI cmdDat)
(codeBufferChangedEventHandler mvarGUI)
(codeBufferDeleteRangeEventHandler mvarGUI)
(codeBufferInsertTextEventHandler mvarGUI)
let newMap = Map.insert node wid codeNoteMap
putMVar mvarGUI $ guiData { codeNoteMapMVarGUIData = newMap}
IF.activateCodeNote builder wid lineNo
-- |
--
--
activateTextEditorWithSearchResult :: MVar MVarGUIData -> DebugCommandData -> IO ()
activateTextEditorWithSearchResult mvarGUI cmdDat = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = searchResultListStoreMVarGUIData guiData
IF.getCurrentSearchResult builder store >>= \case
Nothing -> return ()
Just (IF.SearchResultData filePath lineNo startCol endCol _) -> do
activateTextEditor mvarGUI cmdDat $ HighlightTextRangeData filePath lineNo startCol lineNo endCol
-- |
--
--
findTextEditorByPath :: MVar MVarGUIData -> FilePath -> IO (Maybe IF.TextEditorData)
findTextEditorByPath mvarGUI path = do
guiData <- readMVar mvarGUI
let codeNoteMap = codeNoteMapMVarGUIData guiData
nodeMay = L.find (\node->L.isSuffixOf path (IF.getPathFromNodeData node)) $ Map.keys codeNoteMap
case nodeMay of
Just node -> return . Just $ codeNoteMap Map.! node
Nothing -> return Nothing
-- |
--
--
findCurrentTextEditor :: MVar MVarGUIData -> IO (Maybe (IF.NodeData, IF.TextEditorData))
findCurrentTextEditor mvarGUI = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
noteMap = codeNoteMapMVarGUIData guiData
findCurrent builder $ Map.toList noteMap
where
findCurrent _ [] = return Nothing
findCurrent builder ((n, e):xs) = do
IF.isCurrentTextEditor builder e >>= \case
True -> return $ Just (n, e)
False -> findCurrent builder xs
-- |
--
--
updateSearchResultTag :: MVar MVarGUIData -> DebugCommandData -> FilePath -> IF.TextEditorData -> IO ()
updateSearchResultTag mvarGUI cmdData path editor = do
guiData <- readMVar mvarGUI
let store = searchResultListStoreMVarGUIData guiData
searchDatas <- IF.getSearchResultDataByFilePath store path
IF.updateSearchResultTag editor $ map go searchDatas
where
go (IF.SearchResultData _ lineNo startCol endCol _) = IF.SearchResultTagInfo (lineNo-1) (startCol-1) (endCol-1)
-- |
--
--
textEditorSwitchPageEventHandler :: MVar MVarGUIData -> DebugCommandData -> FilePath -> IO ()
textEditorSwitchPageEventHandler mvarGUI cmdData path = findTextEditorByPath mvarGUI path >>= \case
Nothing -> errorM _LOG_NAME $ "[textEditorSwitchPageEventHandler]invalid text editor."
Just editor -> updateSearchResultTag mvarGUI cmdData path editor
-- |=====================================================================
-- Utility
--
--
-- |
-- すべての変更ファイルを保存する
--
saveAll :: MVar MVarGUIData -> DebugCommandData -> IO [FilePath]
saveAll mvarGUI _ = do
guiData <- readMVar mvarGUI
let noteMap = codeNoteMapMVarGUIData guiData
foldM go [] $ Map.toList noteMap
where
go acc (nodeDat, editor) = IF.isTextEditorModified editor >>= \case
False -> return acc
True -> do
content <- IF.getCodeViewContent editor
saveFile (IF.getPathFromNodeData nodeDat) content
IF.setTextEditorModified editor False
return $ IF.getPathFromNodeData nodeDat : acc
-- |
-- すべての開いているテキストエディッタのコンテンツを再読み込みする。
--
reloadAll :: MVar MVarGUIData -> IO ()
reloadAll mvarGUI = do
guiData <- readMVar mvarGUI
let noteMap = codeNoteMapMVarGUIData guiData
mapM_ go $ Map.toList noteMap
where
go (nodeDat, editor) = do
let path = IF.getPathFromNodeData nodeDat
bs <- loadFile path
(lineNo, colNo) <- IF.getCodeTextLineNumber editor
guiData <- takeMVar mvarGUI
putMVar mvarGUI guiData{unDoReDoFlagMVarGUIData = True}
IF.setContent2TextEditor editor bs
guiData <- takeMVar mvarGUI
putMVar mvarGUI guiData{unDoReDoFlagMVarGUIData = False}
IF.setCursorOnTextEditor editor lineNo colNo
-- |
-- フォルダツリー全体の読み込み
--
loadFolderForest :: String -> [FilePath] -> IO (T.Tree IF.NodeData)
loadFolderForest _ paths = do
topNodes <- foldM go [] $ reverse paths
return $ head topNodes
-- return $ T.Node (IF.FolderNodeData forestName forestName "") topNodes
where
go acc path = do
tree <- loadFolderTree "" path
return $ tree:acc
-- |
-- フォルダツリーの読み込み
--
loadFolderTree :: ModuleName -> FilePath -> IO (T.Tree IF.NodeData)
loadFolderTree modName path = doesDirectoryExist path >>= withDir
where
withDir False = do
errorM _LOG_NAME $ "invalid dirctory:" ++ path
return $ T.Node (IF.FolderNodeData modName ("invalid directory") path) []
withDir True = do
let dirName = takeFileName path
node = T.Node (IF.FolderNodeData modName (""++dirName++"") path) []
items <- getDirectoryContents path
foldM setFolderItem node $ normalizeList items
normalizeList :: [FilePath] -> [FilePath]
normalizeList fs = files ++ dirs
where
items = filter (\s->'.' /= head s) fs
dirs = filter (\s-> all ((/=) '.') s) items
files = filter (\s-> any ((==) '.') s) items
setFolderItem :: T.Tree IF.NodeData -> FilePath -> IO (T.Tree IF.NodeData)
setFolderItem node item = do
let fullPath = path > item
let baseName = takeBaseName item
let nzModName = getNzModName modName baseName -- if True == null modName then baseName else modName <.> baseName
isDir <- doesDirectoryExist fullPath
setFolderItem_ node nzModName fullPath isDir
getNzModName modName baseName
| null modName = getNzModNameWithNullModName baseName
| otherwise = modName <.> baseName
getNzModNameWithNullModName baseName
| null baseName = ""
| isUpper (head baseName) = baseName
| otherwise = ""
setFolderItem_ :: T.Tree IF.NodeData -> ModuleName -> FilePath -> Bool -> IO (T.Tree IF.NodeData)
setFolderItem_ node nzModName fullPath isDir
| True == isDir = do
child <- loadFolderTree nzModName fullPath
return $ addChildTree node child
| otherwise = do
let fileExt = takeExtension fullPath
setHsItem node nzModName fullPath fileExt
setHsItem :: T.Tree IF.NodeData -> ModuleName -> FilePath -> String -> IO (T.Tree IF.NodeData)
setHsItem node nzModName fullPath fileExt
| elem fileExt _AVAILABLE_FILE_EXT = do
let fileName = takeFileName fullPath
let child = T.Node (IF.FileNodeData nzModName (""++fileName++"") fullPath) []
return $ addChildTree node child
| otherwise = return node