phoityne-0.0.2.0: app/Phoityne/IO/GUI/Control.hs
{-# 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
, buildMsgMVarGUIData :: [String]
, 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
, buildMsgMVarGUIData = []
, searchFilesMVarGUIData = []
, startupNodeDataMVarGUIData = Nothing
, ghciAutoStart = autoRun
}
-- |
--
--
createMainWindow :: DebugCommandData -> [FilePath] -> Bool -> IO ()
createMainWindow cmdData paths autoRun = do
-- Storeの作成
builder <- IF.getBuilder
breakStore <- IF.createBreakPointListStore
bindingStore <- IF.createBindingListStore
traceStore <- IF.createTraceDataListStore
searchResultStore <- IF.createSearchResultListStore
treeStore <- loadFolderForest _PROJECT_ROOT_MODULE_NAME paths >>= IF.createTreeStore
-- GUI共有データの作成
mvarGUI <- newMVar $ defaultMVarGUIData builder breakStore treeStore bindingStore traceStore searchResultStore autoRun
-- イベントハンドラの登録
IF.setupMainWindow builder
(mainWindowCloseEventHanlder)
(mainWindowKeyPressEventHandler 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)
(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 >>= \case
True -> return ()
False -> errorM _LOG_NAME "run ghci failed."
-- 開始
IF.start builder
-- |=====================================================================
-- MainWindowのイベントハンドラ
--
-- |
--
--
mainWindowCloseEventHanlder :: IF.MainWindowCloseEventHandler
mainWindowCloseEventHanlder = 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.isDebugStart 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.isBuildStart builder >>= \case
True -> IF.putStrStatusBar builder "build unavailable. Currently building or ghci running."
False -> runClean >> toolBTbuildHandler 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 $ "start 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.isBuildStart builder >>= \case
True -> IF.putStrStatusBar builder "build unavailable. Currently building or ghci running."
False -> do
IF.clearConsole builder
toolBTbuildHandler mvarGUI cmdDat
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "F10" _ _ = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
isStart <- IF.isDebugStart 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.isDebugStart 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
defaultStr <- IF.getSelectedText editor
IF.getSearchKeyBySearchDialog builder defaultStr >>= \case
Nothing -> return True
Just key -> do
clearSearchResultTable mvarGUI
activateSearchResultTab mvarGUI
setSearchFiles mvarGUI [nodeData]
keywordLineSearch [nodeData] key (searchResultHandler mvarGUI)
(lineNo, _) <- IF.getCodeTextLineNumber editor
activateTextEditorWithSearchResult mvarGUI cmdDat $ Just (IF.getPathFromNodeData nodeData, lineNo+1)
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
nodeDatas = [nodeData]
IF.getReplaceByReplaceDialog builder >>= \case
Nothing -> return True
Just (key, rep) -> do
saveAll mvarGUI cmdDat
replaceFiles nodeDatas key rep
reloadAll mvarGUI
-- search
clearSearchResultTable mvarGUI
activateSearchResultTab mvarGUI
setSearchFiles mvarGUI nodeDatas
keywordLineSearch nodeDatas rep (searchResultHandler mvarGUI)
(lineNo, _) <- IF.getCodeTextLineNumber editor
activateTextEditorWithSearchResult mvarGUI cmdDat $ Just (IF.getPathFromNodeData nodeData, lineNo+1)
return True
mainWindowKeyPressEventHandler mvarGUI cmdDat "F3" False _ = do
activateTextEditorWithSearchResult mvarGUI cmdDat Nothing
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
continueWithHighlightTextRangeData mvarGUI cmdData breakPos
-- |
--
--
loadHsFiles :: MVar MVarGUIData -> DebugCommandData -> [FilePath] -> IO ()
loadHsFiles mvarGUI cmdData paths = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
debugStarted <- IF.isDebugStart builder
when debugStarted $ do
IF.putStrStatusBar builder "stop debug and load files."
toolBTdebugStopHandler mvarGUI cmdData
autoRunGHCi mvarGUI cmdData >>= \case
False -> errorM _LOG_NAME "run ghci failed."
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
| otherwise -> do
cmdStr <- getResult
IF.putStrConsole builder cmdStr
return False
-- |
--
--
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 False = return False
withFlag True False = runGHCi mvarGUI cmdData
-- |
--
--
runGHCi :: MVar MVarGUIData -> DebugCommandData -> IO Bool
runGHCi mvarGUI cmdData = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
startCmd = startDebugCommandData cmdData
readLines = readLinesDebugCommandData cmdData
IF.changeTBsOnGHCiStartting builder
IF.clearConsole builder
IF.putStrConsole builder $ "start stack ghci.\n"
startCmd
cont <- readLines (debugStartResultHandler builder)
if | null cont -> IF.changeTBsOnGHCiStopped builder >> return False
| startswith "Ok," (last cont) -> readAndSetPrompt >> IF.changeTBsOnGHCiStarted builder >> return True
| startswith "Failed," (last cont) -> readAndSetPrompt >> IF.changeTBsOnGHCiStarted builder >>return True
| otherwise -> IF.changeTBsOnGHCiStopped builder >> return False
where
readAndSetPrompt = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
readWhile = readWhileDebugCommandData cmdData
setPrompt = promptDebugCommandData cmdData
getResult = readDebugCommandData cmdData
printEvld = printEvldDebugCommandData cmdData
res <- readWhile $ not . endswith "> "
IF.putStrConsole builder res
promptStr <- setPrompt
IF.putStrLnConsole builder promptStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
cmdStr <- printEvld
IF.putStrLnConsole builder cmdStr
cmdStr <- getResult
IF.putStrConsole builder cmdStr
-- |
--
--
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
-- |
-- 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 -> warningM _LOG_NAME $ show err
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 -> warningM _LOG_NAME $ show err
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
continueWithHighlightTextRangeData mvarGUI cmdData breakPos
-- |
-- Event Handler
--
toolBTbuildHandler :: MVar MVarGUIData -> DebugCommandData -> IF.BuildBTClickedEventHandler
toolBTbuildHandler mvarGUI cmdData = do
saveAll mvarGUI cmdData
_ <- forkIO $ do
hid <- IF.addCallback $ buildCallbackHandler mvarGUI True
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
buildStart = buildStartDebugCommandData cmdData
readLine = readLinesDebugCommandData cmdData
exitCmd = stopDebugCommandData cmdData
putMVar mvarGUI guiData{buildMsgMVarGUIData = []}
IF.changeTBsOnBuildStart builder
--IF.clearConsole builder
appendBuildMsg mvarGUI "start stack build.\n"
buildStart
readLine (buildStartResultHandler mvarGUI)
IF.delCallback hid
code <- exitCmd
appendBuildMsg mvarGUI $ "\n" ++ show code ++ "\n"
_ <- IF.addCallback $ buildCallbackHandler mvarGUI False
IF.changeTBsOnBuildFinish builder
return ()
where
-- |
-- Event Handler
--
buildCallbackHandler :: MVar MVarGUIData -> Bool -> IO Bool
buildCallbackHandler mvarGUI doNotDelHandle = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
curMsg = buildMsgMVarGUIData guiData
putMVar mvarGUI guiData{ buildMsgMVarGUIData = [] }
mapM_ (IF.putStrConsole builder) curMsg
return doNotDelHandle
-- |
--
--
buildStartResultHandler :: MVar MVarGUIData -> [String] -> IO Bool
buildStartResultHandler _ [] = return False
buildStartResultHandler mvarGUI strs = do
appendBuildMsg mvarGUI $ last strs
return True
-- |
--
--
appendBuildMsg :: MVar MVarGUIData -> String -> IO ()
appendBuildMsg mvarGUI msg = do
guiData <- takeMVar mvarGUI
let curMsg = buildMsgMVarGUIData guiData
putMVar mvarGUI guiData{ buildMsgMVarGUIData = curMsg ++ [msg] }
-- |
-- 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 -> Either ParseError HighlightTextRangeData -> IO ()
continueWithHighlightTextRangeData mvarGUI cmdData (Left err) = do
warningM _LOG_NAME $ "[continueWithHighlightTextRangeData]" ++ show err
updateBindingTable mvarGUI cmdData
updateTraceTable mvarGUI cmdData
continueWithHighlightTextRangeData mvarGUI cmdData (Right 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 _ = 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 -> IF.FolderTreeSearchAction
folderTreeSearchAction mvarGUI = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
IF.getSelectedFolderTreeAllNodeData builder treeStore >>= withNodeDatas builder
where
withNodeDatas _ [] = errorM _LOG_NAME "invalid node data."
withNodeDatas builder nodeDatas = do
keyMay <- IF.getSearchKeyBySearchDialog builder ""
when (isJust keyMay) $ do
clearSearchResultTable mvarGUI
activateSearchResultTab mvarGUI
setSearchFiles mvarGUI nodeDatas
keywordLineSearch nodeDatas (fromJust keyMay) (searchResultHandler mvarGUI)
-- |
-- Event Handler
--
folderTreeReplaceAction :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeReplaceAction
folderTreeReplaceAction mvarGUI cmdDat = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
treeStore = folderTreeMVarGUIData guiData
IF.getSelectedFolderTreeAllNodeData builder treeStore >>= withNodeDatas builder
where
withNodeDatas _ [] = errorM _LOG_NAME "invalid node data."
withNodeDatas builder nodeDatas = do
IF.getReplaceByReplaceDialog builder >>= \case
Nothing -> return ()
Just (key, rep) -> do
saveAll mvarGUI cmdDat
replaceFiles nodeDatas key rep
reloadAll mvarGUI
-- search
clearSearchResultTable mvarGUI
activateSearchResultTab mvarGUI
setSearchFiles mvarGUI nodeDatas
keywordLineSearch nodeDatas rep (searchResultHandler mvarGUI)
-- |
-- イベントハンドラ
--
folderTreeKeyPressEventHandler :: MVar MVarGUIData -> DebugCommandData -> IF.FolderTreeKeyPressEventHandler
folderTreeKeyPressEventHandler mvarGUI _ "Right" _ _ = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
IF.expandFolderTree builder store
putMVar mvarGUI guiData
return True
folderTreeKeyPressEventHandler mvarGUI _ "Left" _ _ = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
IF.collapseFolderTree builder store
putMVar mvarGUI guiData
return True
folderTreeKeyPressEventHandler mvarGUI cmdDat "Return" _ _ = do
guiData <- takeMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = folderTreeMVarGUIData guiData
nodeMay <- IF.getSelectedFolderTreeNodeData builder store
putMVar mvarGUI guiData
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" _ _ _ _ = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[codeTextKeyPressEventHandler] invalid text editor." >> return True
Just a -> withEditor a
where
withEditor (nodeDat, editor) = do
key <- IF.getSelectedText editor
withKey key $ IF.getPathFromNodeData nodeDat
withKey key path
| null key = return True
| otherwise = autoRunGHCi mvarGUI cmdData >>= \case
False -> errorM _LOG_NAME "run ghci failed." >> return True
True -> do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
res <- IF.isDebugStart 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) >> return True
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
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 _ _ _ _ _ _ _ = return False
-- |
-- イベントハンドラ
--
codeBufferChangedEventHandler :: MVar MVarGUIData -> IO ()
codeBufferChangedEventHandler _ = return ()
-- |
-- イベントハンドラ
--
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 (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
-- 検索
--
-- |
-- 検索対象となったファイル群を共有データに保存する。
--
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 -> (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 -> (FilePath -> Int -> Int -> Int -> String -> IO ()) -> IO ()
searchFile path key hdl = do
bs <- loadFile path
searchLine (TE.pack key) (hdl path) 1 $ TE.lines $ TE.decodeUtf8 bs
-- |
--
--
searchLine :: TE.Text -> (Int -> Int -> Int -> String -> IO ()) -> Int -> [TE.Text] -> IO ()
searchLine _ _ _ [] = return ()
searchLine key hdl lineNo (line:lines) = do
mapM_ go $ TE.breakOnAll key line
searchLine key 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] -> String -> String -> IO ()
replaceFiles [] _ _ = return ()
replaceFiles ((IF.FolderNodeData _ _ _):xs) key rep = replaceFiles xs key rep
replaceFiles ((IF.FileNodeData _ _ path):xs) key rep = replaceFile path key rep >> replaceFiles xs key rep
where
replaceFile :: FilePath -> String -> String -> IO ()
replaceFile path key rep = do
bs <- loadFile path
let res = TE.replace (TE.pack key) (TE.pack rep) $ TE.decodeUtf8 bs
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.isDebugStart 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.isDebugStart 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 -> Maybe IF.SearchResultOffset -> IO ()
activateTextEditorWithSearchResult mvarGUI cmdDat offset = findCurrentTextEditor mvarGUI >>= \case
Nothing -> errorM _LOG_NAME "[activateTextEditorWithSearchResult] 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 = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
store = searchResultListStoreMVarGUIData guiData
IF.nextCurrentSearchResult builder store offset
activateTextEditorWithCurrentSearchResult mvarGUI cmdDat
hasSearched curEditor False = do
guiData <- readMVar mvarGUI
let builder = widgetStoreMVarGUIData guiData
key <- IF.getSearchKeyFromSearchDialog builder
isSearchKey curEditor key
isSearchKey (nodeData, editor) key
| null key = mainWindowKeyPressEventHandler mvarGUI cmdDat "f" False True >> return ()
| otherwise = do
clearSearchResultTable mvarGUI
activateSearchResultTab mvarGUI
setSearchFiles mvarGUI [nodeData]
keywordLineSearch [nodeData] key (searchResultHandler mvarGUI)
(lineNo, _) <- IF.getCodeTextLineNumber editor
activateTextEditorWithSearchResult mvarGUI cmdDat $ Just (IF.getPathFromNodeData nodeData, lineNo+1)
activateTextEditorWithCurrentSearchResult :: MVar MVarGUIData -> DebugCommandData -> IO ()
activateTextEditorWithCurrentSearchResult mvarGUI cmdData = 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 cmdData $ 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
-- |=====================================================================
-- 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 ("<span foreground='black'>invalid directory</span>") path) []
withDir True = do
let dirName = takeFileName path
node = T.Node (IF.FolderNodeData modName ("<span foreground='black'>"++dirName++"</span>") 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 ("<span foreground='black'>"++fileName++"</span>") fullPath) []
return $ addChildTree node child
| otherwise = return node