{-# 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