diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,11 @@ +20160301 phoityne-0.0.4.0 + * [Change] ブレークせずに実行が終了した場合は、デバッグ終了状態に遷移するように変更した。 + * [Change] stack buildの起動引数を「--test --no-run-tests」に変更した。 + * [Change] ghciの起動引数を「--test --no-build --no-load」に変更した。 + * [Fix] F8ショートカットキーを有効化した。 + * [Fix] ファイルを再オープンした際は、エディッタにおいてファイル先頭に移動しないように修正した。 + * [Add] システムフォントの名前とサイズを設定ファイルで指定するように変更した。 + 20160201 phoityne-0.0.3.0 * [Fix] phoityne終了時にghciを停止するように修正した。 diff --git a/app/Phoityne/Constant.hs b/app/Phoityne/Constant.hs --- a/app/Phoityne/Constant.hs +++ b/app/Phoityne/Constant.hs @@ -22,6 +22,13 @@ _INI_SEC_PHOITYNE_GHCI_AUTO_START :: String _INI_SEC_PHOITYNE_GHCI_AUTO_START = "ghci_auto_start" +_INI_SEC_PHOITYNE_FONT_NAME :: String +_INI_SEC_PHOITYNE_FONT_NAME = "system_font_name" + +_INI_SEC_PHOITYNE_FONT_SIZE :: String +_INI_SEC_PHOITYNE_FONT_SIZE = "system_font_size" + + _LOG_NAME :: String _LOG_NAME = "phoityne" @@ -32,47 +39,50 @@ _LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S" -- | --- -- +-- type ModuleName = String - -_HS_FILE_EXT :: String + +_HS_FILE_EXT :: String _HS_FILE_EXT = ".hs" - -_PHOITYNE_GHCI_PROMPT :: String -_PHOITYNE_GHCI_PROMPT = "Phoityne>>= " - -_GHCI_MAIN_PROMPT :: String -_GHCI_MAIN_PROMPT = "*Main> " - -_PROJECT_ROOT_MODULE_NAME :: String -_PROJECT_ROOT_MODULE_NAME = "Project Root" +_PHOITYNE_GHCI_PROMPT :: String +_PHOITYNE_GHCI_PROMPT = "Phoityne>>= " + +_GHCI_PROMPT :: String +_GHCI_PROMPT = "Prelude> " + +_GHCI_MAIN_PROMPT :: String +_GHCI_MAIN_PROMPT = "*Main> " + +_PROJECT_ROOT_MODULE_NAME :: String +_PROJECT_ROOT_MODULE_NAME = "Project Root" + _INDENT_SPACE :: String _INDENT_SPACE = " " - + _COMMENT_TAG :: String _COMMENT_TAG = "-- " - + _UNDO_BUFFER_MAX_SIZE :: Int _UNDO_BUFFER_MAX_SIZE = 100 - + _AVAILABLE_FILE_EXT :: [String] _AVAILABLE_FILE_EXT = [ ".hs" , ".ini" , ".yaml" , ".cabal" - ] + ] _STARTUP_MODULE_COLOR_BLUE :: String -_STARTUP_MODULE_COLOR_BLUE = "blue" +_STARTUP_MODULE_COLOR_BLUE = "" _STARTUP_MODULE_COLOR_BLACK :: String -_STARTUP_MODULE_COLOR_BLACK = "black" +_STARTUP_MODULE_COLOR_BLACK = "" -- | --- --- -_NO_BREAK_POINT_LOCATION :: String -_NO_BREAK_POINT_LOCATION = "No breakpoints found at that location." +-- +-- +_NO_BREAK_POINT_LOCATION :: String +_NO_BREAK_POINT_LOCATION = "No breakpoints found at that location." diff --git a/app/Phoityne/IO/CUI/GHCiControl.hs b/app/Phoityne/IO/CUI/GHCiControl.hs --- a/app/Phoityne/IO/CUI/GHCiControl.hs +++ b/app/Phoityne/IO/CUI/GHCiControl.hs @@ -10,77 +10,79 @@ module Phoityne.IO.CUI.GHCiControl where -- モジュール -import Phoityne.Constant -import Phoityne.IO.Utility +import Phoityne.Constant +import Phoityne.IO.Utility --- システム +-- システム import System.Process -import System.IO -import System.Exit -import System.Log.Logger +import System.IO +import System.Exit +import System.Log.Logger import qualified Control.Exception as E import qualified Data.List as L - --- | --- --- -data ExternalCommandData = ExternalCommandData - { - inExternalCommandData :: Maybe Handle - , outExternalCommandData :: Maybe Handle - , errExternalCommandData :: Maybe Handle - , procExternalCommandData :: Maybe ProcessHandle - } - --- | --- --- -defaultExternalCommandData :: ExternalCommandData -defaultExternalCommandData = ExternalCommandData Nothing Nothing Nothing Nothing +-- | +-- +-- +data ExternalCommandData = ExternalCommandData + { + inExternalCommandData :: Maybe Handle + , outExternalCommandData :: Maybe Handle + , errExternalCommandData :: Maybe Handle + , procExternalCommandData :: Maybe ProcessHandle + } --- | --- --- -run :: String -> [String] -> Maybe FilePath -> IO ExternalCommandData -run cmd opts curDir = flip E.catches handlers $ do +-- | +-- +-- +defaultExternalCommandData :: ExternalCommandData +defaultExternalCommandData = ExternalCommandData Nothing Nothing Nothing Nothing - (stdInReadHandle, stdInWriteHandle) <- createPipe - (outReadHandle, outWriteHandle) <- createPipe - --hSetBuffering stdInReadHandle $ BlockBuffering Nothing -- NoBuffering - hSetBuffering stdInReadHandle NoBuffering - hSetBuffering stdInWriteHandle NoBuffering +-- | +-- +-- +run :: String -> [String] -> Maybe FilePath -> IO ExternalCommandData +run cmd opts curDir = flip E.catches handlers $ do - hSetBuffering outReadHandle NoBuffering - hSetBuffering outWriteHandle NoBuffering + debugM _LOG_NAME "run external command." - osEnc <- getReadHandleEncoding + (fromHaskellHandle, toExternalHandle) <- createPipe + (fromExternalHandle, toHaskellHandle) <- createPipe - hSetEncoding stdInReadHandle osEnc - hSetEncoding stdInWriteHandle utf8 + osEnc <- getReadHandleEncoding - hSetEncoding outReadHandle osEnc - hSetEncoding outWriteHandle utf8 + hSetBuffering toHaskellHandle NoBuffering + hSetEncoding toHaskellHandle osEnc - debugM _LOG_NAME $ cmd ++ (L.intercalate " " opts) - ghciProc <- runProcess cmd opts curDir Nothing (Just stdInReadHandle) (Just outWriteHandle) (Just outWriteHandle) - - return $ ExternalCommandData (Just stdInWriteHandle) (Just outReadHandle) (Just outReadHandle) (Just ghciProc) - + hSetBuffering fromHaskellHandle NoBuffering + hSetEncoding fromHaskellHandle utf8 + + hSetBuffering toExternalHandle NoBuffering + hSetEncoding toExternalHandle utf8 + + hSetBuffering fromExternalHandle NoBuffering + hSetEncoding fromExternalHandle osEnc + + + debugM _LOG_NAME $ "external command : " ++ cmd ++ " " ++ (L.intercalate " " opts) + ghciProc <- runProcess cmd opts curDir Nothing (Just fromHaskellHandle) (Just toHaskellHandle) (Just toHaskellHandle) + + return $ ExternalCommandData (Just toExternalHandle) (Just fromExternalHandle) (Just fromExternalHandle) (Just ghciProc) + where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do - criticalM _LOG_NAME ("waitExit:" ++ show e) + criticalM _LOG_NAME ("run:" ++ show e) return $ ExternalCommandData Nothing Nothing Nothing Nothing - --- | --- --- -waitExit :: ExternalCommandData -> IO ExitCode -waitExit (ExternalCommandData _ _ _ (Just ghciProc)) = flip E.catches handlers $ do - waitForProcess ghciProc + +-- | +-- +-- +waitExit :: ExternalCommandData -> IO ExitCode +waitExit (ExternalCommandData _ _ _ (Just ghciProc)) = flip E.catches handlers $ do + waitForProcess ghciProc where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do @@ -88,60 +90,60 @@ return $ ExitFailure 2 waitExit _ = do criticalM _LOG_NAME "waitExit" - return $ ExitFailure 2 - - --- | --- --- -writeLine :: ExternalCommandData -> String -> IO () + return $ ExitFailure 2 + + +-- | +-- +-- +writeLine :: ExternalCommandData -> String -> IO () writeLine (ExternalCommandData (Just ghciIn) _ _ _) cmd = flip E.catches handlers $ hIsOpen ghciIn >>= \case False -> criticalM _LOG_NAME "[writeLine] handle not open." True -> debugM _LOG_NAME ("[writeLine]" ++ cmd) >> hPutStrLn ghciIn cmd where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("writeLine:" ++ show e) - -writeLine _ _ = criticalM _LOG_NAME "[writeLine] handle is nothing." - --- | --- --- -readWhile :: ExternalCommandData -> (String -> Bool) -> IO String -readWhile (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ go [] - where +writeLine _ _ = criticalM _LOG_NAME "[writeLine] handle is nothing." + + +-- | +-- +-- +readWhile :: ExternalCommandData -> (String -> Bool) -> IO String +readWhile (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ go [] + where go acc = hIsEOF ghciOut >>= \case True -> return acc - False -> do + False -> do c <- hGetChar ghciOut - let acc' = acc ++ [c] - if proc acc' then go acc' + let acc' = acc ++ [c] + if proc acc' then go acc' else return acc' - + handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readWhile:" ++ show e) >> return "" + someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readWhile:" ++ show e) >> return "" readWhile _ _ = criticalM _LOG_NAME "readWhile" >> return "" --- | --- --- -readLineWhileIO :: ExternalCommandData -> ([String] -> IO Bool) -> IO [String] -readLineWhileIO (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ go [] - where +-- | +-- +-- +readLineWhileIO :: ExternalCommandData -> ([String] -> IO Bool) -> IO [String] +readLineWhileIO (ExternalCommandData _ (Just ghciOut) _ _) proc = flip E.catches handlers $ go [] + where go acc = hIsEOF ghciOut >>= \case True -> return acc - False -> do - l <- hGetLine ghciOut - let acc' = acc ++ [l] + False -> do + l <- hGetLine ghciOut + let acc' = acc ++ [l] proc acc' >>= \case - True -> go acc' - False -> return acc' + True -> go acc' + False -> return acc' handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = criticalM _LOG_NAME ("readLineWhileIO:" ++ show e) >> return [] - + readLineWhileIO _ _ = criticalM _LOG_NAME "readLineWhileIO" >> return [] - + diff --git a/app/Phoityne/IO/Control.hs b/app/Phoityne/IO/Control.hs --- a/app/Phoityne/IO/Control.hs +++ b/app/Phoityne/IO/Control.hs @@ -15,14 +15,14 @@ import qualified Phoityne.IO.GUI.Control as GUI import qualified Phoityne.IO.CUI.GHCiControl as GHCI --- システム -import System.Directory +-- システム +import System.Directory import System.Info -import System.Log.Logger -import System.Exit -import Distribution.System -import Control.Concurrent -import Data.String.Utils +import System.Log.Logger +import System.Exit +import Distribution.System +import Control.Concurrent +import Data.String.Utils import Data.Either.Utils import qualified Data.ConfigFile as C @@ -36,147 +36,149 @@ let cwdSet = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_TARGET_DIR autoRun = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_GHCI_AUTO_START + fontName = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_FONT_NAME + fontSize = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_FONT_SIZE cwd <- if "." == cwdSet then getCurrentDirectory else return cwdSet - infoM _LOG_NAME $ "CWD:" ++ cwd - infoM _LOG_NAME $ "OS:" ++ os - infoM _LOG_NAME $ "ARCH:" ++ arch - infoM _LOG_NAME $ "BuildOS:" ++ show buildOS + infoM _LOG_NAME $ "CWD:" ++ cwd + infoM _LOG_NAME $ "OS:" ++ os + infoM _LOG_NAME $ "ARCH:" ++ arch + infoM _LOG_NAME $ "BuildOS:" ++ show buildOS - mvarCUI <- newMVar GHCI.defaultExternalCommandData - - let cmdData = createCmdData mvarCUI cwd - - GUI.createMainWindow cmdData [cwd] autoRun + mvarCUI <- newMVar GHCI.defaultExternalCommandData - return 1 + let cmdData = createCmdData mvarCUI cwd + GUI.createMainWindow cmdData [cwd] autoRun (fontName, fontSize) + + return 1 + where createCmdData mvarCUI cwd = - GUI.DebugCommandData { - GUI.startDebugCommandData = debugStart mvarCUI cwd - , GUI.stopDebugCommandData = stopDebug mvarCUI - , GUI.readDebugCommandData = readResult mvarCUI - , GUI.readLinesDebugCommandData = readLines mvarCUI - , GUI.promptDebugCommandData = execCmd mvarCUI $ ":set prompt \"" ++ _PHOITYNE_GHCI_PROMPT ++ "\"" - , GUI.breakDebugCommandData = setBreak mvarCUI - , GUI.bindingsDebugCommandData = execCmd mvarCUI ":show bindings" - , GUI.runDebugCommandData = runDebug mvarCUI - , GUI.continueDebugCommandData = continueCmd mvarCUI - , GUI.stepDebugCommandData = execCmd mvarCUI ":step" - , GUI.stepOverDebugCommandData = execCmd mvarCUI ":steplocal" - , GUI.printEvldDebugCommandData = execCmd mvarCUI ":set -fprint-evld-with-show" - , GUI.deleteBreakDebugCommandData = \n -> execCmd mvarCUI $ ":delete " ++ show n - , GUI.traceHistDebugCommandData = execCmd mvarCUI ":history" - , GUI.traceBackDebugCommandData = execCmd mvarCUI ":back" - , GUI.traceForwardDebugCommandData = execCmd mvarCUI ":forward" + GUI.DebugCommandData { + GUI.startDebugCommandData = debugStart mvarCUI cwd + , GUI.stopDebugCommandData = stopDebug mvarCUI + , GUI.readDebugCommandData = readResult mvarCUI + , GUI.readLinesDebugCommandData = readLines mvarCUI + , GUI.promptDebugCommandData = execCmd mvarCUI $ ":set prompt \"" ++ _PHOITYNE_GHCI_PROMPT ++ "\"" + , GUI.breakDebugCommandData = setBreak mvarCUI + , GUI.bindingsDebugCommandData = execCmd mvarCUI ":show bindings" + , GUI.runDebugCommandData = runDebug mvarCUI + , GUI.continueDebugCommandData = continueCmd mvarCUI + , GUI.stepDebugCommandData = execCmd mvarCUI ":step" + , GUI.stepOverDebugCommandData = execCmd mvarCUI ":steplocal" + , GUI.printEvldDebugCommandData = execCmd mvarCUI ":set -fprint-evld-with-show" + , GUI.deleteBreakDebugCommandData = \n -> execCmd mvarCUI $ ":delete " ++ show n + , GUI.traceHistDebugCommandData = execCmd mvarCUI ":history" + , GUI.traceBackDebugCommandData = execCmd mvarCUI ":back" + , GUI.traceForwardDebugCommandData = execCmd mvarCUI ":forward" , GUI.forceDebugCommandData = \arg -> execCmd mvarCUI $ ":force " ++ arg - , GUI.execCommandData = execCmd mvarCUI - , GUI.quitDebugCommandData = execCmd mvarCUI ":quit" - , GUI.buildStartDebugCommandData = buildStart mvarCUI cwd + , GUI.execCommandData = execCmd mvarCUI + , GUI.quitDebugCommandData = execCmd mvarCUI ":quit" + , GUI.buildStartDebugCommandData = buildStart mvarCUI cwd , GUI.cleanStartDebugCommandData = cleanStart mvarCUI cwd - , GUI.loadFileDebugCommandData = \f-> execCmd mvarCUI $ ":l " ++ f + , GUI.loadFileDebugCommandData = \f-> execCmd mvarCUI $ ":l " ++ f , GUI.readWhileDebugCommandData = readWhile mvarCUI - , GUI.infoDebugCommandData = \arg -> execCmd mvarCUI $ ":info " ++ arg + , GUI.infoDebugCommandData = \arg -> execCmd mvarCUI $ ":info " ++ arg } - + -- | --- --- -cleanStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () -cleanStart mvarCUI cwd = do - exeData <- GHCI.run "stack" ["clean"] $ Just cwd - takeMVar mvarCUI >> putMVar mvarCUI exeData +-- +-- +cleanStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () +cleanStart mvarCUI cwd = do + exeData <- GHCI.run "stack" ["clean"] $ Just cwd + takeMVar mvarCUI >> putMVar mvarCUI exeData -- | --- --- -debugStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () -debugStart mvarCUI cwd = do - exeData <- GHCI.run "stack" ["ghci"] $ Just cwd - takeMVar mvarCUI >> putMVar mvarCUI exeData +-- +-- +debugStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () +debugStart mvarCUI cwd = do + exeData <- GHCI.run "stack" ["ghci", "--test", "--no-build", "--no-load"] $ Just cwd + takeMVar mvarCUI >> putMVar mvarCUI exeData - + -- | --- --- -buildStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () -buildStart mvarCUI cwd = do - exeData <- GHCI.run "stack" ["build"] $ Just cwd - takeMVar mvarCUI >> putMVar mvarCUI exeData - - +-- +-- +buildStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO () +buildStart mvarCUI cwd = do + exeData <- GHCI.run "stack" ["build", "--test", "--no-run-tests"] $ Just cwd + takeMVar mvarCUI >> putMVar mvarCUI exeData + + -- | --- --- -setBreak :: MVar GHCI.ExternalCommandData - -> String -- module name - -> Int -- linen no - -> IO String -setBreak mvarCUI modName lineNo = do - let cmd = ":break " ++ modName ++ " " ++ show lineNo - execCmd mvarCUI cmd - - +-- +-- +setBreak :: MVar GHCI.ExternalCommandData + -> String -- module name + -> Int -- linen no + -> IO String +setBreak mvarCUI modName lineNo = do + let cmd = ":break " ++ modName ++ " " ++ show lineNo + execCmd mvarCUI cmd + + -- | --- --- -runDebug :: MVar GHCI.ExternalCommandData -> Bool -> IO String -runDebug mvarCUI isTrace = do - let cmd = if isTrace then ":trace main" else "main" - execCmd mvarCUI cmd - - +-- +-- +runDebug :: MVar GHCI.ExternalCommandData -> Bool -> IO String +runDebug mvarCUI isTrace = do + let cmd = if isTrace then ":trace main" else "main" + execCmd mvarCUI cmd + + -- | --- --- -readResult :: MVar GHCI.ExternalCommandData -> IO String -readResult mvarCUI = readWhile mvarCUI $ not . endswith _PHOITYNE_GHCI_PROMPT +-- +-- +readResult :: MVar GHCI.ExternalCommandData -> IO String +readResult mvarCUI = readWhile mvarCUI $ not . endswith _PHOITYNE_GHCI_PROMPT -- | --- --- -readWhile :: MVar GHCI.ExternalCommandData -> (String -> Bool) -> IO String -readWhile mvarCUI proc = do - exeData <- readMVar mvarCUI - GHCI.readWhile exeData proc +-- +-- +readWhile :: MVar GHCI.ExternalCommandData -> (String -> Bool) -> IO String +readWhile mvarCUI proc = do + exeData <- readMVar mvarCUI + GHCI.readWhile exeData proc - + -- | --- --- -readLines :: MVar GHCI.ExternalCommandData -> ([String] -> IO Bool) -> IO [String] -readLines mvarCUI proc = do - exeData <- readMVar mvarCUI - GHCI.readLineWhileIO exeData proc +-- +-- +readLines :: MVar GHCI.ExternalCommandData -> ([String] -> IO Bool) -> IO [String] +readLines mvarCUI proc = do + exeData <- readMVar mvarCUI + GHCI.readLineWhileIO exeData proc - + -- | --- --- -stopDebug :: MVar GHCI.ExternalCommandData -> IO ExitCode -stopDebug mvarCUI = do - exeData <- readMVar mvarCUI - GHCI.waitExit exeData - - +-- +-- +stopDebug :: MVar GHCI.ExternalCommandData -> IO ExitCode +stopDebug mvarCUI = do + exeData <- readMVar mvarCUI + GHCI.waitExit exeData + + -- | --- --- -continueCmd :: MVar GHCI.ExternalCommandData -> Bool -> IO String -continueCmd mvarCUI isTrace = do - let cmd = if isTrace then ":trace" else ":continue" - execCmd mvarCUI cmd +-- +-- +continueCmd :: MVar GHCI.ExternalCommandData -> Bool -> IO String +continueCmd mvarCUI isTrace = do + let cmd = if isTrace then ":trace" else ":continue" + execCmd mvarCUI cmd - + -- | --- --- -execCmd :: MVar GHCI.ExternalCommandData -> String -> IO String -execCmd mvarCUI cmd = do - exeData <- readMVar mvarCUI - GHCI.writeLine exeData cmd - return cmd +-- +-- +execCmd :: MVar GHCI.ExternalCommandData -> String -> IO String +execCmd mvarCUI cmd = do + exeData <- readMVar mvarCUI + GHCI.writeLine exeData cmd + return cmd diff --git a/app/Phoityne/IO/GUI/Control.hs b/app/Phoityne/IO/GUI/Control.hs --- a/app/Phoityne/IO/GUI/Control.hs +++ b/app/Phoityne/IO/GUI/Control.hs @@ -7,2365 +7,2369 @@ {-# 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 - 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) ++ "]") - (mainWindowCloseEventHanlder mvarGUI cmdData) - (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 :: 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.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 "F8" isShift _ = do - guiData <- readMVar mvarGUI - let builder = widgetStoreMVarGUIData guiData - - IF.isBuildStart 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.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.putStrLnConsole 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 (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 --- 検索 --- - --- | --- 検索対象となったファイル群を共有データに保存する。 --- -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 ("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 - - +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) + + 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 + + -- 開始 + 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 + + 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+2) + 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+2) + 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 + + 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 -> 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 <- 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" _ _ _ _ = 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.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) >> 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 (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 +-- 検索 +-- + +-- | +-- 検索対象となったファイル群を共有データに保存する。 +-- +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.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 -> 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+2) + + 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 ("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 + + diff --git a/app/Phoityne/IO/GUI/GTK/BindingTable.hs b/app/Phoityne/IO/GUI/GTK/BindingTable.hs --- a/app/Phoityne/IO/GUI/GTK/BindingTable.hs +++ b/app/Phoityne/IO/GUI/GTK/BindingTable.hs @@ -7,121 +7,112 @@ {-# LANGUAGE DeriveDataTypeable #-} module Phoityne.IO.GUI.GTK.BindingTable ( - BindingListStore -, BindingData(..) -, BindingTableDoubleClickedHandler -, setupBindingTable -, createBindingListStore -, updateBindingTable + BindingListStore +, BindingData(..) +, BindingTableDoubleClickedHandler +, setupBindingTable +, createBindingListStore +, updateBindingTable ) where - + -- モジュール -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility - --- システム -import Graphics.UI.Gtk + +-- システム +import Graphics.UI.Gtk import Control.Monad.IO.Class --- | --- --- +-- | +-- +-- type BindingListStore = ListStore BindingData - --- | --- --- + +-- | +-- +-- type BindingTableDoubleClickedHandler = BindingData -> IO () - + -- | --- --- -data BindingData = BindingData { - varNameBindingData :: String - , modNameBindingData :: String - , valueBindingData :: String - } deriving (Show, Read, Eq, Ord) +-- +-- +data BindingData = BindingData { + varNameBindingData :: String + , modNameBindingData :: String + , valueBindingData :: String + } deriving (Show, Read, Eq, Ord) - + -- | --- --- -updateBindingTable :: ListStore BindingData -> [BindingData] -> IO () -updateBindingTable store dats= do - listStoreClear store - mapM_ (listStoreAppend store) dats +-- +-- +updateBindingTable :: ListStore BindingData -> [BindingData] -> IO () +updateBindingTable store dats= do + listStoreClear store + mapM_ (listStoreAppend store) dats - --- | --- --- -createBindingListStore :: IO BindingListStore -createBindingListStore = listStoreNew ([] :: [BindingData]) - --- | --- --- + +-- | +-- +-- +createBindingListStore :: IO BindingListStore +createBindingListStore = listStoreNew ([] :: [BindingData]) + +-- | +-- +-- setupBindingTable :: Builder -> BindingListStore -> BindingTableDoubleClickedHandler - -> IO () -setupBindingTable builder store evh = do - - treeView <- builderGetObject builder castToTreeView "BindingsTreeView" - - col <- builderGetObject builder castToTreeViewColumn ("BindingsCol1" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := varNameBindingData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("BindingsCol2" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := modNameBindingData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("BindingsCol3" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := valueBindingData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - _ <- on treeView buttonPressEvent $ bindingTableDoubleClickedHandler treeView store evh - - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle - - setFont treeView - widgetShowAll treeView - --- | --- --- -bindingTableDoubleClickedHandler :: TreeView -> ListStore BindingData -> BindingTableDoubleClickedHandler -> EventM EButton Bool -bindingTableDoubleClickedHandler self listStore evh = eventClick >>= \case - DoubleClick -> liftIO $ do - sel <- treeViewGetSelection self - treeSelectionGetSelected sel >>= \case - Nothing -> return False - Just iter -> do - let idx = listStoreIterToIndex iter - bpDat <- listStoreGetValue listStore idx - evh bpDat - return False - + -> IO () +setupBindingTable builder store evh = do + + treeView <- builderGetObject builder castToTreeView "BindingsTreeView" + + col <- builderGetObject builder castToTreeViewColumn ("BindingsCol1" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := varNameBindingData cell + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("BindingsCol2" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := modNameBindingData cell + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("BindingsCol3" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := valueBindingData cell + ] + _ <- treeViewSetModel treeView store + + _ <- on treeView buttonPressEvent $ bindingTableDoubleClickedHandler treeView store evh + + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + widgetShowAll treeView + +-- | +-- +-- +bindingTableDoubleClickedHandler :: TreeView -> ListStore BindingData -> BindingTableDoubleClickedHandler -> EventM EButton Bool +bindingTableDoubleClickedHandler self listStore evh = eventClick >>= \case + DoubleClick -> liftIO $ do + sel <- treeViewGetSelection self + treeSelectionGetSelected sel >>= \case + Nothing -> return False + Just iter -> do + let idx = listStoreIterToIndex iter + bpDat <- listStoreGetValue listStore idx + evh bpDat + return False + _ -> return False - + diff --git a/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs b/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs --- a/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs +++ b/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs @@ -6,249 +6,242 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.IO.GUI.GTK.BreakPointTable ( - BreakPointListStore -, BreakPointData(..) -, BreakPointDataKey -, getBreakCondition -, DeleteAllBreakBTClickedEventHandler -, BreakPointTableDoubleClickedHandler -, setupBreakPointTable -, createBreakPointListStore -, addBreakPoint2Table -, deleteFromBreakPointListStore -, getBreakPointList -, updateBreakPointTable -, findBreakPointData -, highLightBreakPointTableRow +module Phoityne.IO.GUI.GTK.BreakPointTable ( + BreakPointListStore +, BreakPointData(..) +, BreakPointDataKey +, getBreakCondition +, DeleteAllBreakBTClickedEventHandler +, BreakPointTableDoubleClickedHandler +, setupBreakPointTable +, createBreakPointListStore +, addBreakPoint2Table +, deleteFromBreakPointListStore +, getBreakPointList +, updateBreakPointTable +, findBreakPointData +, highLightBreakPointTableRow ) where - + -- モジュール -import Phoityne.Constant -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility - --- システム -import Graphics.UI.Gtk +import Phoityne.Constant +import Phoityne.IO.GUI.GTK.Constant +import Phoityne.IO.GUI.GTK.Utility + +-- システム +import Graphics.UI.Gtk import Control.Monad.IO.Class -import System.Log.Logger -import qualified Data.List as L - +import System.Log.Logger +import qualified Data.List as L + -- | --- --- -data BreakPointData = - BreakPointData { - moduleNameBreakPointData :: String - , filePathBreakPointData :: FilePath - , lineNoBreakPointData :: Int - , breakNoBreakPointData :: Maybe Int - , conditionBreakPointData :: String - } deriving (Show, Read, Eq, Ord) +-- +-- +data BreakPointData = + BreakPointData { + moduleNameBreakPointData :: String + , filePathBreakPointData :: FilePath + , lineNoBreakPointData :: Int + , breakNoBreakPointData :: Maybe Int + , conditionBreakPointData :: String + } deriving (Show, Read, Eq, Ord) --- | --- --- -type BreakPointTableDoubleClickedHandler = BreakPointData -> IO () - -- | --- --- +-- +-- +type BreakPointTableDoubleClickedHandler = BreakPointData -> IO () + +-- | +-- +-- type BreakPointDataKey = (FilePath, Int) -- | --- --- -type BreakPointListStore = ListStore BreakPointData - +-- +-- +type BreakPointListStore = ListStore BreakPointData + -- | --- --- -type DeleteAllBreakBTClickedEventHandler = IO () - --- | --- --- -createBreakPointListStore :: IO BreakPointListStore -createBreakPointListStore = listStoreNew ([] :: [BreakPointData]) - --- | --- --- +-- +-- +type DeleteAllBreakBTClickedEventHandler = IO () + +-- | +-- +-- +createBreakPointListStore :: IO BreakPointListStore +createBreakPointListStore = listStoreNew ([] :: [BreakPointData]) + +-- | +-- +-- setupBreakPointTable :: Builder -> BreakPointListStore -> BreakPointTableDoubleClickedHandler -> DeleteAllBreakBTClickedEventHandler - -> IO () -setupBreakPointTable builder store evh deleteEvh = do - - treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol1" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := moduleNameBreakPointData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - - col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol2" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := filePathBreakPointData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - - col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol3" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := show (lineNoBreakPointData cell) - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - - col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol4" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := conditionBreakPointData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - set renderer [cellTextEditable := True] - _ <- on renderer edited $ breakPointsConditionEditedHandler treeView store - - _ <- on treeView buttonPressEvent $ breakPointTableDoubleClickedHandler treeView store evh - - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle + -> IO () +setupBreakPointTable builder store evh deleteEvh = do - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DELETE - onToolButtonClicked bt deleteEvh + treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol1" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := moduleNameBreakPointData cell + -- , cellTextFont := _FONT_DESC + -- , cellTextSize := 9 + ] + + col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol2" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := filePathBreakPointData cell + ] + + col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol3" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := show (lineNoBreakPointData cell) + ] + + col <- builderGetObject builder castToTreeViewColumn ("BreakPointCol4" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := conditionBreakPointData cell + ] + set renderer [cellTextEditable := True] + _ <- on renderer edited $ breakPointsConditionEditedHandler treeView store + + _ <- on treeView buttonPressEvent $ breakPointTableDoubleClickedHandler treeView store evh + + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DELETE + onToolButtonClicked bt deleteEvh widgetSetSensitive bt True - - setFont treeView - widgetShowAll treeView - - --- | --- --- -breakPointsConditionEditedHandler :: TreeView -> ListStore BreakPointData -> TreePath -> String -> IO () -breakPointsConditionEditedHandler treeView listStore treePath value = do - treeViewGetModel treeView >>= \case - Nothing -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]model not found." - Just model -> withModel model - - where - withModel model = treeModelGetIter model treePath >>= \case - Nothing -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]treeIter not found." - Just iter -> newData iter >>= listStoreSetValue listStore (listStoreIterToIndex iter) - - newData iter = do - dat <- listStoreGetValue listStore (listStoreIterToIndex iter) - return dat{conditionBreakPointData = value} - --- | --- --- -breakPointTableDoubleClickedHandler :: TreeView -> ListStore BreakPointData -> BreakPointTableDoubleClickedHandler -> EventM EButton Bool -breakPointTableDoubleClickedHandler self listStore evh = eventClick >>= \case - DoubleClick -> liftIO $ do - sel <- treeViewGetSelection self - treeSelectionGetSelected sel >>= \case - Nothing -> return False - Just iter -> do - let idx = listStoreIterToIndex iter - bpDat <- listStoreGetValue listStore idx - evh bpDat - return False - - _ -> return False + widgetShowAll treeView + -- | --- --- -addBreakPoint2Table :: BreakPointListStore -> BreakPointData -> IO () +-- +-- +breakPointsConditionEditedHandler :: TreeView -> ListStore BreakPointData -> TreePath -> String -> IO () +breakPointsConditionEditedHandler treeView listStore treePath value = do + treeViewGetModel treeView >>= \case + Nothing -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]model not found." + Just model -> withModel model + + where + withModel model = treeModelGetIter model treePath >>= \case + Nothing -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]treeIter not found." + Just iter -> newData iter >>= listStoreSetValue listStore (listStoreIterToIndex iter) + + newData iter = do + dat <- listStoreGetValue listStore (listStoreIterToIndex iter) + return dat{conditionBreakPointData = value} + +-- | +-- +-- +breakPointTableDoubleClickedHandler :: TreeView -> ListStore BreakPointData -> BreakPointTableDoubleClickedHandler -> EventM EButton Bool +breakPointTableDoubleClickedHandler self listStore evh = eventClick >>= \case + DoubleClick -> liftIO $ do + sel <- treeViewGetSelection self + treeSelectionGetSelected sel >>= \case + Nothing -> return False + Just iter -> do + let idx = listStoreIterToIndex iter + bpDat <- listStoreGetValue listStore idx + evh bpDat + return False + + _ -> return False + + +-- | +-- +-- +addBreakPoint2Table :: BreakPointListStore -> BreakPointData -> IO () addBreakPoint2Table = add2ListStore - + -- | --- --- -deleteFromBreakPointListStore :: ListStore BreakPointData -> BreakPointDataKey -> IO () -deleteFromBreakPointListStore store (path, lineNo) = - treeModelForeach (castToTreeModel store) deleteData - where - deleteData iter = do - let idx = listStoreIterToIndex iter - (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx - if (curPath == path) && (curLineNo == lineNo) then listStoreRemove store idx >> return True - else return False - +-- +-- +deleteFromBreakPointListStore :: ListStore BreakPointData -> BreakPointDataKey -> IO () +deleteFromBreakPointListStore store (path, lineNo) = + treeModelForeach (castToTreeModel store) deleteData + where + deleteData iter = do + let idx = listStoreIterToIndex iter + (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx + if (curPath == path) && (curLineNo == lineNo) then listStoreRemove store idx >> return True + else return False + -- | --- --- -updateBreakPointTable :: ListStore BreakPointData -> BreakPointDataKey -> BreakPointData -> IO () -updateBreakPointTable store (path, lineNo) newDat = do - treeModelForeach (castToTreeModel store) updateData - where - updateData iter = do - let idx = listStoreIterToIndex iter - (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx - if (curPath == path) && (curLineNo == lineNo) then listStoreSetValue store idx newDat >> return True - else return False - +-- +-- +updateBreakPointTable :: ListStore BreakPointData -> BreakPointDataKey -> BreakPointData -> IO () +updateBreakPointTable store (path, lineNo) newDat = do + treeModelForeach (castToTreeModel store) updateData + where + updateData iter = do + let idx = listStoreIterToIndex iter + (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx + if (curPath == path) && (curLineNo == lineNo) then listStoreSetValue store idx newDat >> return True + else return False + -- | --- --- -findBreakPointData :: ListStore BreakPointData -> BreakPointDataKey -> IO (Maybe BreakPointData) -findBreakPointData store (path, lineNo) = do - xs <- listStoreToList store - return $ L.find findData xs - where - findData (BreakPointData _ curPath curLineNo _ _) = (curPath == path) && (curLineNo == lineNo) - +-- +-- +findBreakPointData :: ListStore BreakPointData -> BreakPointDataKey -> IO (Maybe BreakPointData) +findBreakPointData store (path, lineNo) = do + xs <- listStoreToList store + return $ L.find findData xs + where + findData (BreakPointData _ curPath curLineNo _ _) = (curPath == path) && (curLineNo == lineNo) + -- | --- --- -getBreakPointList :: ListStore a -> IO [a] -getBreakPointList = listStoreToList - +-- +-- +getBreakPointList :: ListStore a -> IO [a] +getBreakPointList = listStoreToList + -- | --- --- -highLightBreakPointTableRow :: Builder -> ListStore BreakPointData -> BreakPointDataKey -> IO () -highLightBreakPointTableRow builder listStore (path, lineNo) = do - treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW - sel <- treeViewGetSelection treeView - treeViewGetModel treeView >>= \case - Nothing -> errorM _LOG_NAME $ "[highLightBreakPointTableRow]invalid highlight break point table." - Just model -> treeModelForeach model $ highLight sel - - where - highLight sel iter = do - let idx = listStoreIterToIndex iter - (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue listStore idx - if (L.isSuffixOf path curPath) && (curLineNo == lineNo) then treeSelectionSelectIter sel iter >> return True - else return False - +-- +-- +highLightBreakPointTableRow :: Builder -> ListStore BreakPointData -> BreakPointDataKey -> IO () +highLightBreakPointTableRow builder listStore (path, lineNo) = do + treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW + sel <- treeViewGetSelection treeView + treeViewGetModel treeView >>= \case + Nothing -> errorM _LOG_NAME $ "[highLightBreakPointTableRow]invalid highlight break point table." + Just model -> treeModelForeach model $ highLight sel + + where + highLight sel iter = do + let idx = listStoreIterToIndex iter + (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue listStore idx + if (L.isSuffixOf path curPath) && (curLineNo == lineNo) then treeSelectionSelectIter sel iter >> return True + else return False + -- | --- --- -getBreakCondition :: ListStore BreakPointData -> BreakPointDataKey -> IO String -getBreakCondition listStore (path, lineNo) = do - bps <- listStoreToList listStore - case L.find go bps of +-- +-- +getBreakCondition :: ListStore BreakPointData -> BreakPointDataKey -> IO String +getBreakCondition listStore (path, lineNo) = do + bps <- listStoreToList listStore + case L.find go bps of Nothing -> do errorM _LOG_NAME $ "[getBreakCondition]invalid break point data. " ++ path ++ ":" ++ show lineNo - return "" - Just (BreakPointData _ _ _ _ condStr) -> return condStr - where - go (BreakPointData _ curPath curLineNo _ _) = (L.isSuffixOf curPath path) && (curLineNo == lineNo) - + return "" + Just (BreakPointData _ _ _ _ condStr) -> return condStr + where + go (BreakPointData _ curPath curLineNo _ _) = (L.isSuffixOf curPath path) && (curLineNo == lineNo) + diff --git a/app/Phoityne/IO/GUI/GTK/ConsoleView.hs b/app/Phoityne/IO/GUI/GTK/ConsoleView.hs --- a/app/Phoityne/IO/GUI/GTK/ConsoleView.hs +++ b/app/Phoityne/IO/GUI/GTK/ConsoleView.hs @@ -8,120 +8,114 @@ {-# LANGUAGE DeriveDataTypeable #-} module Phoityne.IO.GUI.GTK.ConsoleView ( - ConsoleDoubleClickedHandler -, setupConsoleView -, putStrConsole -, putStrLnConsole + ConsoleDoubleClickedHandler +, setupConsoleView +, putStrConsole +, putStrLnConsole , clearConsole ) where -- モジュール import Phoityne.Constant -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility - --- システム -import GHC.Float -import Graphics.UI.Gtk +import Phoityne.IO.GUI.GTK.Constant +import Phoityne.IO.GUI.GTK.Utility + +-- システム +import GHC.Float +import Graphics.UI.Gtk import Control.Monad.IO.Class -import System.Log.Logger +import System.Log.Logger import Data.String.Utils -import qualified Data.Text as T +import qualified Data.Text as T --- | --- --- -type ConsoleDoubleClickedHandler = String -> IO () +-- | +-- +-- +type ConsoleDoubleClickedHandler = String -> IO () --- | --- --- -setupConsoleView :: Builder -> ConsoleDoubleClickedHandler -> IO () -setupConsoleView builder evh = do - textView <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW - - _ <- on textView buttonPressEvent $ consoleDoubleClickedHandler textView evh - _ <- on textView keyPressEvent $ eventKeyName >>= \k->if k==T.pack("F7") then return True else return False - - let widget = castToWidget textView - - fontDesc <- fontDescriptionNew - fontDescriptionSetFamily fontDesc (_FONT_DESC) - fontDescriptionSetSize fontDesc 9 - widgetOverrideFont widget $ Just fontDesc - - --- | --- --- -consoleDoubleClickedHandler :: TextView -> ConsoleDoubleClickedHandler -> EventM EButton Bool -consoleDoubleClickedHandler self evh = eventClick >>= \case - DoubleClick -> doubleClicked >> return True - _ -> return False - - where - doubleClicked = do - (_, posYd) <- eventCoordinates - liftIO $ do - scrollY <- textViewGetVadjustment self >>= adjustmentGetValue - let posY = scrollY + posYd - - (stIter, _) <- textViewGetLineAtY self $ double2Int posY - edIter <- textIterCopy stIter - _ <- textViewForwardDisplayLineEnd self edIter - buf <- textViewGetBuffer self - str <- textBufferGetText buf stIter edIter True - evh str +-- | +-- +-- +setupConsoleView :: Builder -> ConsoleDoubleClickedHandler -> IO () +setupConsoleView builder evh = do + textView <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW + _ <- on textView buttonPressEvent $ consoleDoubleClickedHandler textView evh + _ <- on textView keyPressEvent $ eventKeyName >>= \k->if k==T.pack("F7") then return True else return False --- | --- --- + return () + +-- | +-- +-- +consoleDoubleClickedHandler :: TextView -> ConsoleDoubleClickedHandler -> EventM EButton Bool +consoleDoubleClickedHandler self evh = eventClick >>= \case + DoubleClick -> doubleClicked >> return True + _ -> return False + + where + doubleClicked = do + (_, posYd) <- eventCoordinates + liftIO $ do + scrollY <- textViewGetVadjustment self >>= adjustmentGetValue + let posY = scrollY + posYd + + (stIter, _) <- textViewGetLineAtY self $ double2Int posY + edIter <- textIterCopy stIter + _ <- textViewForwardDisplayLineEnd self edIter + buf <- textViewGetBuffer self + str <- textBufferGetText buf stIter edIter True + evh str + + +-- | +-- +-- clearConsole :: Builder -> IO () clearConsole builder = do - view <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW + view <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW buf <- textViewGetBuffer view textBufferSetText buf (""::String) - - --- | --- --- -putStrConsole :: Builder -> String -> IO () -putStrConsole = append2Console - --- | --- --- -putStrLnConsole :: Builder -> String -> IO () -putStrLnConsole builder str = append2Console builder (str ++ "\n") - --- | --- --- -append2Console :: Builder -> String -> IO () -append2Console builder msg = do + +-- | +-- +-- +putStrConsole :: Builder -> String -> IO () +putStrConsole = append2Console + +-- | +-- +-- +putStrLnConsole :: Builder -> String -> IO () +putStrLnConsole builder str = append2Console builder (str ++ "\n") + +-- | +-- +-- +append2Console :: Builder -> String -> IO () +append2Console builder msg = do + debugM _LOG_NAME $ strip msg - textView <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW - buf <- textViewGetBuffer textView - iter <- textBufferGetEndIter buf - textBufferInsert buf iter msg - - window <- builderGetObject builder castToWindow _WINDOW_NAME - widgetShowAll window - - scroll <- builderGetObject builder castToScrolledWindow _NAME_CONSOLE_SCROLLED_WINDOW - widgetShowAll scroll - - forceEvent - - lineNum <- textBufferGetLineCount buf - iter <- textBufferGetIterAtLine buf lineNum - _ <- textViewScrollToIter textView iter 0.0 Nothing - - forceEvent - - return () + textView <- builderGetObject builder castToTextView _NAME_CONSOLE_TEXT_VIEW + buf <- textViewGetBuffer textView + iter <- textBufferGetEndIter buf + textBufferInsert buf iter msg + + window <- builderGetObject builder castToWindow _WINDOW_NAME + widgetShowAll window + + scroll <- builderGetObject builder castToScrolledWindow _NAME_CONSOLE_SCROLLED_WINDOW + widgetShowAll scroll + + forceEvent + + lineNum <- textBufferGetLineCount buf + iter <- textBufferGetIterAtLine buf lineNum + _ <- textViewScrollToIter textView iter 0.0 Nothing + + forceEvent + + return () diff --git a/app/Phoityne/IO/GUI/GTK/Constant.hs b/app/Phoityne/IO/GUI/GTK/Constant.hs --- a/app/Phoityne/IO/GUI/GTK/Constant.hs +++ b/app/Phoityne/IO/GUI/GTK/Constant.hs @@ -6,128 +6,128 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.IO.GUI.GTK.Constant +module Phoityne.IO.GUI.GTK.Constant where - --- モジュール - --- システム -import qualified Data.Text as T -import System.FilePath - --- | --- + +-- モジュール + +-- システム +import qualified Data.Text as T +import System.FilePath + +-- | -- -_GLADE_FILE :: String -_GLADE_FILE = "conf" "Phoityne.glade" +-- +_GLADE_FILE :: String +_GLADE_FILE = "conf" "Phoityne.glade" -_FONT_DESC :: String -_FONT_DESC = "MS Gothic" - - -_WINDOW_NAME :: String -_WINDOW_NAME = "MainWindow" - -_NAME_TREE_VIEW :: String -_NAME_TREE_VIEW = "TreeView" - -_NAME_TREE_VIEW_MENU :: String -_NAME_TREE_VIEW_MENU = "TreeViewPopupMenu" - -_NAME_TREE_VIEW_MENU_CREATE_FOLDER :: String -_NAME_TREE_VIEW_MENU_CREATE_FOLDER = "TreeViewPopupCreateFolderAction" - -_NAME_TREE_VIEW_MENU_CREATE_FILE :: String -_NAME_TREE_VIEW_MENU_CREATE_FILE = "TreeViewPopupCreateFileAction" - -_NAME_TREE_VIEW_MENU_RENAME :: String -_NAME_TREE_VIEW_MENU_RENAME = "TreeViewPopupRenameAction" - -_NAME_TREE_VIEW_MENU_DELETE :: String -_NAME_TREE_VIEW_MENU_DELETE = "TreeViewPopupDeleteAction" - -_NAME_TREE_VIEW_MENU_SEARCH :: String -_NAME_TREE_VIEW_MENU_SEARCH = "TreeViewPopupSearchAction" - -_NAME_TREE_VIEW_MENU_REPLACE :: String -_NAME_TREE_VIEW_MENU_REPLACE = "TreeViewPopupReplaceAction" +-- _FONT_DESC :: String +-- _FONT_DESC = "MS Gothic" + +_WINDOW_NAME :: String +_WINDOW_NAME = "MainWindow" + +_NAME_TREE_VIEW :: String +_NAME_TREE_VIEW = "TreeView" + +_NAME_TREE_VIEW_MENU :: String +_NAME_TREE_VIEW_MENU = "TreeViewPopupMenu" + +_NAME_TREE_VIEW_MENU_CREATE_FOLDER :: String +_NAME_TREE_VIEW_MENU_CREATE_FOLDER = "TreeViewPopupCreateFolderAction" + +_NAME_TREE_VIEW_MENU_CREATE_FILE :: String +_NAME_TREE_VIEW_MENU_CREATE_FILE = "TreeViewPopupCreateFileAction" + +_NAME_TREE_VIEW_MENU_RENAME :: String +_NAME_TREE_VIEW_MENU_RENAME = "TreeViewPopupRenameAction" + +_NAME_TREE_VIEW_MENU_DELETE :: String +_NAME_TREE_VIEW_MENU_DELETE = "TreeViewPopupDeleteAction" + +_NAME_TREE_VIEW_MENU_SEARCH :: String +_NAME_TREE_VIEW_MENU_SEARCH = "TreeViewPopupSearchAction" + +_NAME_TREE_VIEW_MENU_REPLACE :: String +_NAME_TREE_VIEW_MENU_REPLACE = "TreeViewPopupReplaceAction" + _NAME_TREE_VIEW_MENU_STARTUP :: String -_NAME_TREE_VIEW_MENU_STARTUP = "TreeViewPopupStartupAction" - -_NAME_CODE_NOTE :: String -_NAME_CODE_NOTE = "CodeNote" - -_NAME_MAIN_PANED :: String -_NAME_MAIN_PANED = "MainPaned" - -_NAME_CODE_PANED :: String -_NAME_CODE_PANED = "CodePaned" - -_NAME_TOOL_BT_DEBUG_START :: String -_NAME_TOOL_BT_DEBUG_START = "DebugStartBT" - -_NAME_TOOL_BT_DEBUG_STOP :: String -_NAME_TOOL_BT_DEBUG_STOP = "DebugStopBT" - -_NAME_TOOL_BT_STEP_OVER :: String -_NAME_TOOL_BT_STEP_OVER = "StepOverBT" - -_NAME_TOOL_BT_STEP_IN :: String -_NAME_TOOL_BT_STEP_IN = "StepInBT" - -_NAME_TOOL_BT_CONTINUE :: String -_NAME_TOOL_BT_CONTINUE = "ContinueBT" - -_NAME_TOOL_BT_BUILD :: String -_NAME_TOOL_BT_BUILD = "BuildBT" - -_NAME_TOOL_BT_DELETE :: String -_NAME_TOOL_BT_DELETE = "BreakPointDeleteBT" - -_NAME_TOOL_BT_SAVE :: String -_NAME_TOOL_BT_SAVE = "SaveBT" - -_NAME_TOOL_BT_INDENT :: String -_NAME_TOOL_BT_INDENT = "IndentBT" +_NAME_TREE_VIEW_MENU_STARTUP = "TreeViewPopupStartupAction" -_NAME_TOOL_BT_UNINDENT :: String -_NAME_TOOL_BT_UNINDENT = "UnindentBT" +_NAME_CODE_NOTE :: String +_NAME_CODE_NOTE = "CodeNote" -_NAME_TOOL_BT_COMMENT :: String -_NAME_TOOL_BT_COMMENT = "BlockCommentBT" +_NAME_MAIN_PANED :: String +_NAME_MAIN_PANED = "MainPaned" -_NAME_TOOL_BT_UNCOMMENT :: String -_NAME_TOOL_BT_UNCOMMENT = "BlockUnCommentBT" +_NAME_CODE_PANED :: String +_NAME_CODE_PANED = "CodePaned" -_NAME_TOOL_BT_START_GHCI :: String -_NAME_TOOL_BT_START_GHCI = "StartGHCiBT" +_NAME_TOOL_BT_DEBUG_START :: String +_NAME_TOOL_BT_DEBUG_START = "DebugStartBT" -_NAME_TOOL_BT_STOP_GHCI :: String -_NAME_TOOL_BT_STOP_GHCI = "StopGHCiBT" +_NAME_TOOL_BT_DEBUG_STOP :: String +_NAME_TOOL_BT_DEBUG_STOP = "DebugStopBT" -_NAME_TOOL_BT_DEL_SEARCH :: String -_NAME_TOOL_BT_DEL_SEARCH = "SearchResultDeleteBT" +_NAME_TOOL_BT_STEP_OVER :: String +_NAME_TOOL_BT_STEP_OVER = "StepOverBT" -_NAME_CONSOLE_TEXT_VIEW :: String -_NAME_CONSOLE_TEXT_VIEW = "ConsoleTextView" - -_NAME_CONSOLE_SCROLLED_WINDOW :: String -_NAME_CONSOLE_SCROLLED_WINDOW = "ConsoleScrolledWindow" +_NAME_TOOL_BT_STEP_IN :: String +_NAME_TOOL_BT_STEP_IN = "StepInBT" -_NAME_TAG_TABLE :: String -_NAME_TAG_TABLE = "CodeTextTagTable" - -_WIDGET_NAME_BREAK_POINT_TREE_VIEW :: String -_WIDGET_NAME_BREAK_POINT_TREE_VIEW = "BreakPointTreeView" - -_BREAK_POINT_MARK :: T.Text -_BREAK_POINT_MARK = T.pack "BreakPointPosMark" - -_BREAK_POINT_HIGHLIGHT_TAG :: T.Text -_BREAK_POINT_HIGHLIGHT_TAG = T.pack "BreakPointHighlightTag" - - +_NAME_TOOL_BT_CONTINUE :: String +_NAME_TOOL_BT_CONTINUE = "ContinueBT" + +_NAME_TOOL_BT_BUILD :: String +_NAME_TOOL_BT_BUILD = "BuildBT" + +_NAME_TOOL_BT_DELETE :: String +_NAME_TOOL_BT_DELETE = "BreakPointDeleteBT" + +_NAME_TOOL_BT_SAVE :: String +_NAME_TOOL_BT_SAVE = "SaveBT" + +_NAME_TOOL_BT_INDENT :: String +_NAME_TOOL_BT_INDENT = "IndentBT" + +_NAME_TOOL_BT_UNINDENT :: String +_NAME_TOOL_BT_UNINDENT = "UnindentBT" + +_NAME_TOOL_BT_COMMENT :: String +_NAME_TOOL_BT_COMMENT = "BlockCommentBT" + +_NAME_TOOL_BT_UNCOMMENT :: String +_NAME_TOOL_BT_UNCOMMENT = "BlockUnCommentBT" + +_NAME_TOOL_BT_START_GHCI :: String +_NAME_TOOL_BT_START_GHCI = "StartGHCiBT" + +_NAME_TOOL_BT_STOP_GHCI :: String +_NAME_TOOL_BT_STOP_GHCI = "StopGHCiBT" + +_NAME_TOOL_BT_DEL_SEARCH :: String +_NAME_TOOL_BT_DEL_SEARCH = "SearchResultDeleteBT" + +_NAME_CONSOLE_TEXT_VIEW :: String +_NAME_CONSOLE_TEXT_VIEW = "ConsoleTextView" + +_NAME_CONSOLE_SCROLLED_WINDOW :: String +_NAME_CONSOLE_SCROLLED_WINDOW = "ConsoleScrolledWindow" + +_NAME_TAG_TABLE :: String +_NAME_TAG_TABLE = "CodeTextTagTable" + +_WIDGET_NAME_BREAK_POINT_TREE_VIEW :: String +_WIDGET_NAME_BREAK_POINT_TREE_VIEW = "BreakPointTreeView" + +_BREAK_POINT_MARK :: T.Text +_BREAK_POINT_MARK = T.pack "BreakPointPosMark" + +_BREAK_POINT_HIGHLIGHT_TAG :: T.Text +_BREAK_POINT_HIGHLIGHT_TAG = T.pack "BreakPointHighlightTag" + + _NAME_STATUS_BAR :: String _NAME_STATUS_BAR = "StatusBar" diff --git a/app/Phoityne/IO/GUI/GTK/FolderTree.hs b/app/Phoityne/IO/GUI/GTK/FolderTree.hs --- a/app/Phoityne/IO/GUI/GTK/FolderTree.hs +++ b/app/Phoityne/IO/GUI/GTK/FolderTree.hs @@ -6,428 +6,420 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.IO.GUI.GTK.FolderTree ( - FolderTreeStore -, NodeData(..) -, FolderTreeDoubleClickedHandler -, FolderTreePopupHandler -, FolderTreeCreateFolderAction -, FolderTreeCreateFileAction -, FolderTreeRenameAction -, FolderTreeDeleteAction -, FolderTreeSearchAction -, FolderTreeReplaceAction -, FolderTreeStartupAction -, FolderTreeKeyPressEventHandler -, createTreeStore -, addNode2TreeStore -, setupFolderTree -, getPathFromNodeData -, getModNameFromNodeData -, findTreeNode -, getSelectedFolderTreeNodeData -, getSelectedFolderTreeAllNodeData -, folderTreeMenuPopup -, getNameFromNodeData +module Phoityne.IO.GUI.GTK.FolderTree ( + FolderTreeStore +, NodeData(..) +, FolderTreeDoubleClickedHandler +, FolderTreePopupHandler +, FolderTreeCreateFolderAction +, FolderTreeCreateFileAction +, FolderTreeRenameAction +, FolderTreeDeleteAction +, FolderTreeSearchAction +, FolderTreeReplaceAction +, FolderTreeStartupAction +, FolderTreeKeyPressEventHandler +, createTreeStore +, addNode2TreeStore +, setupFolderTree +, getPathFromNodeData +, getModNameFromNodeData +, findTreeNode +, getSelectedFolderTreeNodeData +, getSelectedFolderTreeAllNodeData +, folderTreeMenuPopup +, getNameFromNodeData , expandCollapseFolderTree , expandFolderTree , collapseFolderTree , updateTreeNode , changeNameColorOfNodeData ) where - + -- モジュール -import Phoityne.Constant -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility - --- システム -import GHC.Float -import Graphics.UI.Gtk +import Phoityne.Constant +import Phoityne.IO.GUI.GTK.Constant + +-- システム +import GHC.Float +import Graphics.UI.Gtk import Control.Monad.IO.Class -import Data.String.Utils +import Data.String.Utils import qualified Data.Tree as TR -import qualified Data.Text as T +import qualified Data.Text as T -- | --- --- -type FolderTreeStore = TreeStore NodeData - -type FolderTreeKeyPressEventHandler = String -> Bool -> Bool -> IO Bool +-- +-- +type FolderTreeStore = TreeStore NodeData -type FolderTreeDoubleClickedHandler = IO () - -type FolderTreePopupHandler = IO () - -type FolderTreeCreateFolderAction = IO () - -type FolderTreeCreateFileAction = IO () - -type FolderTreeRenameAction = IO () - -type FolderTreeDeleteAction = IO () - -type FolderTreeSearchAction = IO () - -type FolderTreeReplaceAction = IO () - +type FolderTreeKeyPressEventHandler = String -> Bool -> Bool -> IO Bool + +type FolderTreeDoubleClickedHandler = IO () + +type FolderTreePopupHandler = IO () + +type FolderTreeCreateFolderAction = IO () + +type FolderTreeCreateFileAction = IO () + +type FolderTreeRenameAction = IO () + +type FolderTreeDeleteAction = IO () + +type FolderTreeSearchAction = IO () + +type FolderTreeReplaceAction = IO () + type FolderTreeStartupAction = IO () -- | --- --- -data NodeData = - FileNodeData { - moduleFileNodeData :: String - , nameFileNodeData :: FilePath - , pathFileNodeData :: FilePath - } - | - FolderNodeData { - moduleFolderNodeData :: String - , nameFolderNodeData :: FilePath - , pathFolderNodeData :: FilePath - } deriving (Show, Read, Eq) - -instance Ord NodeData where - compare (FileNodeData x _ _) (FileNodeData x' _ _) - | x == x' = EQ - | x < x' = LT - | otherwise = GT - - compare (FolderNodeData x _ _) (FolderNodeData x' _ _) - | x == x' = EQ - | x < x' = LT - | otherwise = GT - - compare (FolderNodeData _ _ _) (FileNodeData _ _ _) = LT - +-- +-- +data NodeData = + FileNodeData { + moduleFileNodeData :: String + , nameFileNodeData :: FilePath + , pathFileNodeData :: FilePath + } + | + FolderNodeData { + moduleFolderNodeData :: String + , nameFolderNodeData :: FilePath + , pathFolderNodeData :: FilePath + } deriving (Show, Read, Eq) + +instance Ord NodeData where + compare (FileNodeData x _ _) (FileNodeData x' _ _) + | x == x' = EQ + | x < x' = LT + | otherwise = GT + + compare (FolderNodeData x _ _) (FolderNodeData x' _ _) + | x == x' = EQ + | x < x' = LT + | otherwise = GT + + compare (FolderNodeData _ _ _) (FileNodeData _ _ _) = LT + compare (FileNodeData _ _ _) (FolderNodeData _ _ _) = GT - --- | --- --- -getNameFromNodeData :: NodeData -> String -getNameFromNodeData (FileNodeData _ name _) = name -getNameFromNodeData (FolderNodeData _ name _) = name +-- | +-- +-- +getNameFromNodeData :: NodeData -> String +getNameFromNodeData (FileNodeData _ name _) = name +getNameFromNodeData (FolderNodeData _ name _) = name --- | --- --- + +-- | +-- +-- changeNameColorOfNodeData :: NodeData -> String -> String -> NodeData changeNameColorOfNodeData nodeDat@(FolderNodeData _ _ _) _ _ = nodeDat changeNameColorOfNodeData nodeDat@(FileNodeData _ name _) oldCol newCol = nodeDat { nameFileNodeData = changeColor name} where changeColor val = replace oldCol newCol val - --- | --- --- -getPathFromNodeData :: NodeData -> FilePath -getPathFromNodeData (FileNodeData _ _ path) = path -getPathFromNodeData (FolderNodeData _ _ path) = path - --- | --- --- -getModNameFromNodeData :: NodeData -> String -getModNameFromNodeData (FileNodeData name _ _) = name -getModNameFromNodeData (FolderNodeData name _ _) = name --- | --- --- -createTreeStore :: TR.Tree NodeData -> IO FolderTreeStore -createTreeStore tree = treeStoreNew [tree] +-- | +-- +-- +getPathFromNodeData :: NodeData -> FilePath +getPathFromNodeData (FileNodeData _ _ path) = path +getPathFromNodeData (FolderNodeData _ _ path) = path +-- | +-- +-- +getModNameFromNodeData :: NodeData -> String +getModNameFromNodeData (FileNodeData name _ _) = name +getModNameFromNodeData (FolderNodeData name _ _) = name --- | --- Event Handler --- -folderTreeKeyPressEventHandler :: TreeView -> FolderTreeKeyPressEventHandler -> EventM EKey Bool -folderTreeKeyPressEventHandler _ evh = do - name <- eventKeyName - mods <- eventModifier - - liftIO $ evh (T.unpack name) (elem Shift mods) (elem Control mods) - --- | --- --- +-- | +-- +-- +createTreeStore :: TR.Tree NodeData -> IO FolderTreeStore +createTreeStore tree = treeStoreNew [tree] + + +-- | +-- Event Handler +-- +folderTreeKeyPressEventHandler :: TreeView -> FolderTreeKeyPressEventHandler -> EventM EKey Bool +folderTreeKeyPressEventHandler _ evh = do + name <- eventKeyName + mods <- eventModifier + + liftIO $ evh (T.unpack name) (elem Shift mods) (elem Control mods) + +-- | +-- +-- setupFolderTree :: Builder - -> FolderTreeStore - -> FolderTreeDoubleClickedHandler - -> FolderTreePopupHandler - -> FolderTreeCreateFolderAction - -> FolderTreeCreateFileAction - -> FolderTreeRenameAction - -> FolderTreeDeleteAction - -> FolderTreeSearchAction + -> FolderTreeStore + -> FolderTreeDoubleClickedHandler + -> FolderTreePopupHandler + -> FolderTreeCreateFolderAction + -> FolderTreeCreateFileAction + -> FolderTreeRenameAction + -> FolderTreeDeleteAction + -> FolderTreeSearchAction -> FolderTreeReplaceAction - -> FolderTreeKeyPressEventHandler + -> FolderTreeKeyPressEventHandler -> FolderTreeStartupAction - -> IO () -setupFolderTree builder store doublEH popupEH creteFolderAct createFileAct renameAct deleteAct searchAct replaceAct keyHandler startupAct = do - - colLabel <- labelNew $ Just "Explorer" - fontDesc <- fontDescriptionNew - fontDescriptionSetFamily fontDesc (_FONT_DESC) - fontDescriptionSetSize fontDesc 8 - widgetOverrideFont colLabel $ Just fontDesc - - col <- treeViewColumnNew - treeViewColumnSetWidget col $ Just colLabel - - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - - cellLayoutSetAttributes col renderer store $ \cell -> [ cellTextMarkup := Just (getNameFromNodeData cell), cellTextFont := _FONT_DESC, cellTextSize := 9] - - treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU - setFont treeViewMenu - - treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW - _ <- treeViewSetModel treeView store - _ <- treeViewAppendColumn treeView col - _ <- on treeView buttonPressEvent $ folderTreeClickedHandler treeView doublEH popupEH - _ <- on treeView popupMenuSignal $ getSelectedFolderTreeNodeData builder store >>= folderTreeMenuPopup builder >> return True - _ <- on treeView keyPressEvent $ folderTreeKeyPressEventHandler treeView keyHandler - - treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER - _ <- on treeViewCreateFolderAction actionActivated creteFolderAct - - treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE - _ <- on treeViewCreateFileAction actionActivated createFileAct - - treeViewRenameAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_RENAME - _ <- on treeViewRenameAction actionActivated renameAct - - treeViewDeleteAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_DELETE - _ <- on treeViewDeleteAction actionActivated deleteAct - - treeViewSearchAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_SEARCH - _ <- on treeViewSearchAction actionActivated searchAct - - treeViewReplaceAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_REPLACE - _ <- on treeViewReplaceAction actionActivated replaceAct - - treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP - _ <- on treeViewStartupAction actionActivated startupAct + -> IO () +setupFolderTree builder store doublEH popupEH creteFolderAct createFileAct renameAct deleteAct searchAct replaceAct keyHandler startupAct = do - setFont treeView - - widgetShowAll colLabel - widgetShowAll treeView - + colLabel <- labelNew $ Just "Explorer" - + col <- treeViewColumnNew + treeViewColumnSetWidget col $ Just colLabel + + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + + cellLayoutSetAttributes col renderer store $ \cell -> [ cellTextMarkup := Just (getNameFromNodeData cell)] + + _ <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU + + treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW + _ <- treeViewSetModel treeView store + _ <- treeViewAppendColumn treeView col + _ <- on treeView buttonPressEvent $ folderTreeClickedHandler treeView doublEH popupEH + _ <- on treeView popupMenuSignal $ getSelectedFolderTreeNodeData builder store >>= folderTreeMenuPopup builder >> return True + _ <- on treeView keyPressEvent $ folderTreeKeyPressEventHandler treeView keyHandler + + treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER + _ <- on treeViewCreateFolderAction actionActivated creteFolderAct + + treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE + _ <- on treeViewCreateFileAction actionActivated createFileAct + + treeViewRenameAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_RENAME + _ <- on treeViewRenameAction actionActivated renameAct + + treeViewDeleteAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_DELETE + _ <- on treeViewDeleteAction actionActivated deleteAct + + treeViewSearchAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_SEARCH + _ <- on treeViewSearchAction actionActivated searchAct + + treeViewReplaceAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_REPLACE + _ <- on treeViewReplaceAction actionActivated replaceAct + + treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP + _ <- on treeViewStartupAction actionActivated startupAct + + widgetShowAll colLabel + widgetShowAll treeView + + + -- | --- Event Handler --- +-- Event Handler +-- folderTreeClickedHandler :: TreeView - -> FolderTreeDoubleClickedHandler - -> FolderTreePopupHandler - -> EventM EButton Bool -folderTreeClickedHandler treeView doubleEH popupEH = do - bt <- eventButton - ck <- eventClick + -> FolderTreeDoubleClickedHandler + -> FolderTreePopupHandler + -> EventM EButton Bool +folderTreeClickedHandler treeView doubleEH popupEH = do + bt <- eventButton + ck <- eventClick - (posXd, posYd) <- eventCoordinates - liftIO $ do + (posXd, posYd) <- eventCoordinates + liftIO $ do treeViewGetPathAtPos treeView (double2Int posXd, double2Int posYd) >>= \case Nothing -> return False Just (treePath, _, _) -> do sel <- treeViewGetSelection treeView treeSelectionSelectPath sel treePath - handle bt ck - - where - handle LeftButton DoubleClick = doubleEH >> return True - handle RightButton SingleClick = popupEH >> return True - handle _ _ = return False - + handle bt ck + + where + handle LeftButton DoubleClick = doubleEH >> return True + handle RightButton SingleClick = popupEH >> return True + handle _ _ = return False + -- | --- Event Handler --- -folderTreeMenuPopup :: Builder -> Maybe NodeData -> IO () -folderTreeMenuPopup builder (Just (FolderNodeData _ fileName _)) - | _PROJECT_ROOT_MODULE_NAME == fileName = return () - | otherwise = do - treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER - actionSetSensitive treeViewCreateFolderAction True - treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE +-- Event Handler +-- +folderTreeMenuPopup :: Builder -> Maybe NodeData -> IO () +folderTreeMenuPopup builder (Just (FolderNodeData _ fileName _)) + | _PROJECT_ROOT_MODULE_NAME == fileName = return () + | otherwise = do + treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER + actionSetSensitive treeViewCreateFolderAction True + treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE actionSetSensitive treeViewCreateFileAction True - treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP - actionSetSensitive treeViewStartupAction False - treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU - menuPopup treeViewMenu Nothing -folderTreeMenuPopup builder (Just (FileNodeData _ _ path)) = do - treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER - actionSetSensitive treeViewCreateFolderAction False - treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE - actionSetSensitive treeViewCreateFileAction False + treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP + actionSetSensitive treeViewStartupAction False + treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU + menuPopup treeViewMenu Nothing +folderTreeMenuPopup builder (Just (FileNodeData _ _ path)) = do + treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER + actionSetSensitive treeViewCreateFolderAction False + treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE + actionSetSensitive treeViewCreateFileAction False - treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP + treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP actionSetSensitive treeViewStartupAction (endswith _HS_FILE_EXT path) - + - treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU - menuPopup treeViewMenu Nothing - + treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU + menuPopup treeViewMenu Nothing + folderTreeMenuPopup _ _ = return () - --- | --- --- -addNode2TreeStore :: FolderTreeStore -> NodeData -> NodeData -> IO () -addNode2TreeStore store parent@(FolderNodeData _ _ _) child = do - findTreeNodeIter store (\n->n == parent) >>= \case - Nothing -> return () - Just iter -> do - path <- treeIter2Path store iter - childIdx <- getInsertIndex iter - treeStoreInsert store path childIdx child - - where - getInsertIndex parentIter = do - let model = castToTreeModel store - treeModelIterChildren model parentIter >>= \case - Nothing -> return 0 - Just iter -> getIndexWithIter iter 0 - - getIndexWithIter iter idx = do - path <- treeIter2Path store iter - value <- treeStoreGetValue store path - if child < value then return idx - else searchNext iter (idx+1) - - searchNext iter idx = do - let model = castToTreeModel store - treeModelIterNext model iter >>= \case - Nothing -> return idx - Just next -> getIndexWithIter next idx - -addNode2TreeStore _ _ _ = return () - --- | --- --- -treeIter2Path :: TreeStore a -> TreeIter -> IO TreePath -treeIter2Path store iter = treeModelGetPath (castToTreeModel store) iter - --- | --- --- -findTreeNode :: FolderTreeStore -> (NodeData -> Bool) -> IO (Maybe NodeData) -findTreeNode store finder = do - findTreeNodeIter store finder >>= \case - Nothing -> return Nothing - Just iter -> do - path <- treeIter2Path store iter - value <- treeStoreGetValue store path - return $ Just value --- | --- --- -updateTreeNode :: FolderTreeStore -> NodeData -> NodeData -> IO () -updateTreeNode store oldDat newDat = do - findTreeNodeIter store ((==) oldDat) >>= \case - Nothing -> return () - Just iter -> do - path <- treeIter2Path store iter - treeStoreSetValue store path newDat - --- | --- --- -findTreeNodeIter :: FolderTreeStore -> (NodeData -> Bool) -> IO (Maybe TreeIter) -findTreeNodeIter store finder = do - let model = castToTreeModel store - treeModelGetIterFirst model >>= \case - Nothing -> return Nothing - Just iter -> findTreeNodeByIter model iter - - where - findTreeNodeByIter model iter = do - path <- treeModelGetPath model iter - node <- treeStoreGetValue store path - - if True == finder node then return (Just iter) else searchChild model iter - - searchChild model iter = - treeModelIterChildren model iter >>= \case - Just child -> findTreeNodeByIter model child >>= \case - Just iter -> return (Just iter) - Nothing -> searchNext model iter - - Nothing -> searchNext model iter - - searchNext model iter = - treeModelIterNext model iter >>= \case - Just next -> findTreeNodeByIter model next - Nothing -> return Nothing - -- | --- Event Handler --- -getSelectedFolderTreeNodeData :: Builder -> TreeStore NodeData -> IO (Maybe NodeData) -getSelectedFolderTreeNodeData builder store = do - treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case - Nothing -> return Nothing - Just iter -> treeViewGetModel treeView >>= \case - Nothing -> return Nothing - Just model -> do - path <- treeModelGetPath model iter - val <- treeStoreGetValue store path - return $ Just val - +-- +-- +addNode2TreeStore :: FolderTreeStore -> NodeData -> NodeData -> IO () +addNode2TreeStore store parent@(FolderNodeData _ _ _) child = do + findTreeNodeIter store (\n->n == parent) >>= \case + Nothing -> return () + Just iter -> do + path <- treeIter2Path store iter + childIdx <- getInsertIndex iter + treeStoreInsert store path childIdx child + + where + getInsertIndex parentIter = do + let model = castToTreeModel store + treeModelIterChildren model parentIter >>= \case + Nothing -> return 0 + Just iter -> getIndexWithIter iter 0 + + getIndexWithIter iter idx = do + path <- treeIter2Path store iter + value <- treeStoreGetValue store path + if child < value then return idx + else searchNext iter (idx+1) + + searchNext iter idx = do + let model = castToTreeModel store + treeModelIterNext model iter >>= \case + Nothing -> return idx + Just next -> getIndexWithIter next idx + +addNode2TreeStore _ _ _ = return () + -- | --- Event Handler --- -getSelectedFolderTreeAllNodeData :: Builder -> TreeStore NodeData -> IO [NodeData] -getSelectedFolderTreeAllNodeData builder store = do - treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case - Nothing -> return [] - Just iter -> treeViewGetModel treeView >>= \case - Nothing -> return [] - Just model -> do - path <- treeModelGetPath model iter - val <- treeStoreGetValue store path - treeModelIterChildren model iter >>= \case - Just childIter -> collectAll model childIter [val] - Nothing -> return [val] - - where - collectAll model iter acc = do - path <- treeModelGetPath model iter - val <- treeStoreGetValue store path - - let acc' = val : acc - acc'' <- treeModelIterChildren model iter >>= \case - Just childIter -> collectAll model childIter acc' - Nothing -> return acc' - - treeModelIterNext model iter >>= \case - Just nextIter -> collectAll model nextIter acc'' - Nothing -> return acc'' - +-- +-- +treeIter2Path :: TreeStore a -> TreeIter -> IO TreePath +treeIter2Path store iter = treeModelGetPath (castToTreeModel store) iter + -- | -- --- +-- +findTreeNode :: FolderTreeStore -> (NodeData -> Bool) -> IO (Maybe NodeData) +findTreeNode store finder = do + findTreeNodeIter store finder >>= \case + Nothing -> return Nothing + Just iter -> do + path <- treeIter2Path store iter + value <- treeStoreGetValue store path + return $ Just value + +-- | +-- +-- +updateTreeNode :: FolderTreeStore -> NodeData -> NodeData -> IO () +updateTreeNode store oldDat newDat = do + findTreeNodeIter store ((==) oldDat) >>= \case + Nothing -> return () + Just iter -> do + path <- treeIter2Path store iter + treeStoreSetValue store path newDat + +-- | +-- +-- +findTreeNodeIter :: FolderTreeStore -> (NodeData -> Bool) -> IO (Maybe TreeIter) +findTreeNodeIter store finder = do + let model = castToTreeModel store + treeModelGetIterFirst model >>= \case + Nothing -> return Nothing + Just iter -> findTreeNodeByIter model iter + + where + findTreeNodeByIter model iter = do + path <- treeModelGetPath model iter + node <- treeStoreGetValue store path + + if True == finder node then return (Just iter) else searchChild model iter + + searchChild model iter = + treeModelIterChildren model iter >>= \case + Just child -> findTreeNodeByIter model child >>= \case + Just iter -> return (Just iter) + Nothing -> searchNext model iter + + Nothing -> searchNext model iter + + searchNext model iter = + treeModelIterNext model iter >>= \case + Just next -> findTreeNodeByIter model next + Nothing -> return Nothing + +-- | +-- Event Handler +-- +getSelectedFolderTreeNodeData :: Builder -> TreeStore NodeData -> IO (Maybe NodeData) +getSelectedFolderTreeNodeData builder store = do + treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case + Nothing -> return Nothing + Just iter -> treeViewGetModel treeView >>= \case + Nothing -> return Nothing + Just model -> do + path <- treeModelGetPath model iter + val <- treeStoreGetValue store path + return $ Just val + +-- | +-- Event Handler +-- +getSelectedFolderTreeAllNodeData :: Builder -> TreeStore NodeData -> IO [NodeData] +getSelectedFolderTreeAllNodeData builder store = do + treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case + Nothing -> return [] + Just iter -> treeViewGetModel treeView >>= \case + Nothing -> return [] + Just model -> do + path <- treeModelGetPath model iter + val <- treeStoreGetValue store path + treeModelIterChildren model iter >>= \case + Just childIter -> collectAll model childIter [val] + Nothing -> return [val] + + where + collectAll model iter acc = do + path <- treeModelGetPath model iter + val <- treeStoreGetValue store path + + let acc' = val : acc + acc'' <- treeModelIterChildren model iter >>= \case + Just childIter -> collectAll model childIter acc' + Nothing -> return acc' + + treeModelIterNext model iter >>= \case + Just nextIter -> collectAll model nextIter acc'' + Nothing -> return acc'' + +-- | +-- +-- expandCollapseFolderTree :: Builder -> TreeStore NodeData -> IO () expandCollapseFolderTree builder store = do - treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case + treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case Nothing -> return () Just iter -> do path <- treeIter2Path store iter @@ -437,27 +429,27 @@ -- | -- --- +-- expandFolderTree :: Builder -> TreeStore NodeData -> IO () expandFolderTree builder store = do - treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case + treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case Nothing -> return () Just iter -> do path <- treeIter2Path store iter treeViewRowExpanded treeView path >>= \case True -> return () False -> treeViewExpandToPath treeView path - + -- | -- --- +-- collapseFolderTree :: Builder -> TreeStore NodeData -> IO () collapseFolderTree builder store = do - treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case + treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case Nothing -> return () Just iter -> do path <- treeIter2Path store iter diff --git a/app/Phoityne/IO/GUI/GTK/Interface.hs b/app/Phoityne/IO/GUI/GTK/Interface.hs --- a/app/Phoityne/IO/GUI/GTK/Interface.hs +++ b/app/Phoityne/IO/GUI/GTK/Interface.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.IO.GUI.GTK.Interface ( +module Phoityne.IO.GUI.GTK.Interface ( module Phoityne.IO.GUI.GTK.ConsoleView , module Phoityne.IO.GUI.GTK.BindingTable , module Phoityne.IO.GUI.GTK.BreakPointTable @@ -16,100 +16,101 @@ , module Phoityne.IO.GUI.GTK.SearchResultTable -- Main -, WidgetStore -, MainWindowCloseEventHandler +, WidgetStore +, MainWindowCloseEventHandler , MainWindowKeyPressEventHandler -, CallbackHandlerId -, getBuilder -, start +, CallbackHandlerId +, getBuilder +, start , setupMainWindow , addCallback , delCallback , putStrStatusBar +, putStrLnConsoleAsync --- ToolButton -, DebugStartBTClickedEventHandler -, DebugStopBTClickedEventHandler -, StepOverBTClickedEventHandler -, StepInBTClickedEventHandler -, BuildBTClickedEventHandler -, SaveBTClickedEventHandler -, IndentBTClickedEventHandler -, UnIndentBTClickedEventHandler -, CommentBTClickedEventHandler -, UnCommentBTClickedEventHandler +-- ToolButton +, DebugStartBTClickedEventHandler +, DebugStopBTClickedEventHandler +, StepOverBTClickedEventHandler +, StepInBTClickedEventHandler +, BuildBTClickedEventHandler +, SaveBTClickedEventHandler +, IndentBTClickedEventHandler +, UnIndentBTClickedEventHandler +, CommentBTClickedEventHandler +, UnCommentBTClickedEventHandler , setupToolButton , changeTBsOnGHCiStartting , changeTBsOnGHCiStarted -, changeTBsOnGHCiStopped -, changeTBsOnDebugStarted -, changeTBsOnDebugStopped -, changeTBsOnBuildStart -, changeTBsOnBuildFinish -, isDebugStart -, isBuildStart +, changeTBsOnGHCiStopped +, changeTBsOnDebugStarted +, changeTBsOnDebugStopped +, changeTBsOnBuildStart +, changeTBsOnBuildFinish +, isDebugStarted +, isBuildStarted , isGHCiStarted - + -- Dialog -, getNameByFolderTreeDialog +, getNameByFolderTreeDialog , getSearchKeyBySearchDialog -, getSearchKeyFromSearchDialog -, getReplaceByReplaceDialog +, getSearchKeyFromSearchDialog +, getReplaceByReplaceDialog , initSearchDialog , initReplaceDialog -) where +) where -- モジュール -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.BreakPointTable -import Phoityne.IO.GUI.GTK.TextEditor -import Phoityne.IO.GUI.GTK.BindingTable -import Phoityne.IO.GUI.GTK.TraceTable -import Phoityne.IO.GUI.GTK.FolderTree -import Phoityne.IO.GUI.GTK.SearchResultTable -import Phoityne.IO.GUI.GTK.ConsoleView +import Phoityne.IO.GUI.GTK.Constant +import Phoityne.IO.GUI.GTK.BreakPointTable +import Phoityne.IO.GUI.GTK.TextEditor +import Phoityne.IO.GUI.GTK.BindingTable +import Phoityne.IO.GUI.GTK.TraceTable +import Phoityne.IO.GUI.GTK.FolderTree +import Phoityne.IO.GUI.GTK.SearchResultTable +import Phoityne.IO.GUI.GTK.ConsoleView -- システム -import Paths_phoityne -import Data.Maybe -import Control.Monad.IO.Class -import Graphics.UI.Gtk -import qualified Data.Text as T - --- | --- --- -type WidgetStore = Builder - -type DebugStartBTClickedEventHandler = IO () - -type DebugStopBTClickedEventHandler = IO () - -type StepOverBTClickedEventHandler = IO () - -type StepInBTClickedEventHandler = IO () - -type ContinueBTClickedEventHandler = IO () - -type BuildBTClickedEventHandler = IO () - -type SaveBTClickedEventHandler = IO () - -type IndentBTClickedEventHandler = IO () +import Paths_phoityne +import Data.Maybe +import Control.Monad.IO.Class +import Graphics.UI.Gtk +import qualified Data.Text as T -type UnIndentBTClickedEventHandler = IO () +-- | +-- +-- +type WidgetStore = Builder -type CommentBTClickedEventHandler = IO () +type DebugStartBTClickedEventHandler = IO () -type UnCommentBTClickedEventHandler = IO () +type DebugStopBTClickedEventHandler = IO () +type StepOverBTClickedEventHandler = IO () + +type StepInBTClickedEventHandler = IO () + +type ContinueBTClickedEventHandler = IO () + +type BuildBTClickedEventHandler = IO () + +type SaveBTClickedEventHandler = IO () + +type IndentBTClickedEventHandler = IO () + +type UnIndentBTClickedEventHandler = IO () + +type CommentBTClickedEventHandler = IO () + +type UnCommentBTClickedEventHandler = IO () + type StartGHCiBTClickedEventHandler = IO () - + type StopGHCiBTClickedEventHandler = IO () --- | --- --- +-- | +-- +-- type CallbackHandlerId = HandlerId @@ -117,148 +118,178 @@ -- |===================================================================== -- Main -- - --- | + +-- | -- priorityHighIdle --- priorityDefaultIdle --- +-- priorityDefaultIdle +-- addCallback :: IO Bool -> IO CallbackHandlerId addCallback f = idleAdd f priorityDefaultIdle - --- | --- --- + +-- | +-- +-- delCallback :: CallbackHandlerId -> IO () delCallback = idleRemove --- | --- +-- | -- -getGladeFile :: IO String +-- +getGladeFile :: IO String getGladeFile = getDataFileName _GLADE_FILE - --- | --- --- + +-- | +-- +-- getBuilder :: IO Builder -getBuilder = do - initGUI +getBuilder = do + initGUI - builder <- builderNew + builder <- builderNew gfile <- getGladeFile builderAddFromFile builder gfile - return builder + return builder - --- | --- --- -start :: Builder -> IO () -start builder = do - window <- builderGetObject builder castToWindow _WINDOW_NAME - widgetShowAll window - mainGUI - --- | --- --- -type MainWindowCloseEventHandler = IO () -type MainWindowKeyPressEventHandler = String -> Bool -> Bool -> IO Bool +-- | +-- +-- +start :: Builder -> IO () +start builder = do + window <- builderGetObject builder castToWindow _WINDOW_NAME + widgetShowAll window + mainGUI --- | --- --- + +-- | +-- +-- +type MainWindowCloseEventHandler = IO () +type MainWindowKeyPressEventHandler = String -> Bool -> Bool -> IO Bool + +-- | +-- +-- setupMainWindow :: Builder -> String + -> (String, Int) -> MainWindowCloseEventHandler -> MainWindowKeyPressEventHandler - -> IO () -setupMainWindow builder title closeEvt keyEvt = do - - settings <- fromJust <$> settingsGetDefault - settingsSetStringProperty settings "gtk-font-name" _FONT_DESC "" - settingsSetStringProperty settings "gtk-menu-bar-accel" "" "" - - window <- builderGetObject builder castToWindow _WINDOW_NAME + -> IO () +setupMainWindow builder title systemFont closeEvt keyEvt = do + settings <- fromJust <$> settingsGetDefault + settingsSetStringProperty settings "gtk-font-name" fontDesc "" + settingsSetLongProperty settings "gtk-primary-button-warps-slider" 0 "" + + window <- builderGetObject builder castToWindow _WINDOW_NAME + set window [windowTitle := title] - - on window deleteEvent $ mainWindowCloseEventHandler window closeEvt - on window keyPressEvent $ mainWindowKeyPressEventHandler window keyEvt - - mainPaned <- builderGetObject builder castToPaned _NAME_MAIN_PANED - panedSetPosition mainPaned 200 - - codePaned <- builderGetObject builder castToPaned _NAME_CODE_PANED - panedSetPosition codePaned 350 + on window deleteEvent $ mainWindowCloseEventHandler window closeEvt + on window keyPressEvent $ mainWindowKeyPressEventHandler window keyEvt + + mainPaned <- builderGetObject builder castToPaned _NAME_MAIN_PANED + panedSetPosition mainPaned 200 + + codePaned <- builderGetObject builder castToPaned _NAME_CODE_PANED + panedSetPosition codePaned 350 + note <- builderGetObject builder castToNotebook _NAME_CODE_NOTE on note switchPage $ switchPageEventHandler note builder return () - --- | --- Event Handler --- -mainWindowCloseEventHandler :: Window -> MainWindowCloseEventHandler -> EventM EAny Bool -mainWindowCloseEventHandler self proc = liftIO $ do - proc - widgetDestroy self - mainQuit - return True + where + fontDesc = (fst systemFont) ++ " " ++ show (snd systemFont) - --- | --- Event Handler --- -mainWindowKeyPressEventHandler :: Window -> MainWindowKeyPressEventHandler -> EventM EKey Bool -mainWindowKeyPressEventHandler _ evh = do - name <- eventKeyName - mods <- eventModifier - - liftIO $ evh (T.unpack name) (elem Shift mods) (elem Control mods) --- | --- +-- | +-- Event Handler -- +mainWindowCloseEventHandler :: Window -> MainWindowCloseEventHandler -> EventM EAny Bool +mainWindowCloseEventHandler self proc = liftIO $ do + proc + widgetDestroy self + mainQuit + + return True + + +-- | +-- Event Handler +-- +mainWindowKeyPressEventHandler :: Window -> MainWindowKeyPressEventHandler -> EventM EKey Bool +mainWindowKeyPressEventHandler _ evh = do + name <- eventKeyName + mods <- eventModifier + + liftIO $ evh (T.unpack name) (elem Shift mods) (elem Control mods) + +-- | +-- +-- +isBuildStarted :: Builder -> IO Bool +isBuildStarted builder = do + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD + isBuild <- widgetGetSensitive bt + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + isGHCiStop <- widgetGetSensitive bt + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + isGHCiStart <- widgetGetSensitive bt + + return $ (False == isBuild) && (False == isGHCiStart) && (False == isGHCiStop) + + +-- | +-- +-- isGHCiStarted :: Builder -> IO Bool -isGHCiStarted builder = do - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI - widgetGetSensitive bt +isGHCiStarted builder = do + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD + isBuild <- widgetGetSensitive bt --- | --- --- -isDebugStart :: Builder -> IO Bool -isDebugStart builder = do - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetGetSensitive bt - --- | --- --- -isBuildStart :: Builder -> IO Bool -isBuildStart builder = do - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + isGHCiStop <- widgetGetSensitive bt + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + isGHCiStart <- widgetGetSensitive bt + + return $ (False == isBuild) && (False == isGHCiStart) && (True == isGHCiStop) + + +-- | +-- +-- +isDebugStarted :: Builder -> IO Bool +isDebugStarted builder = do + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD isBuild <- widgetGetSensitive bt - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI isGHCiStop <- widgetGetSensitive bt bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI - isGHCiStart <- widgetGetSensitive bt + isGHCiStart <- widgetGetSensitive bt - return $ (False == isBuild) && (True == isGHCiStop) && (False == isGHCiStart) + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + isDebugStart <- widgetGetSensitive bt --- | --- --- + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + isDebugStop <- widgetGetSensitive bt + + return $ (False == isBuild) && (False == isGHCiStart) && (True == isGHCiStop) && (False == isDebugStart) && (True == isDebugStop) + + +-- | +-- +-- switchPageEventHandler :: Notebook -> Builder -> Int -> IO () switchPageEventHandler note builder pageId = do path <- notebookGetNthPage note pageId >>= \case @@ -270,9 +301,9 @@ putStrStatusBar builder path --- | --- --- +-- | +-- +-- putStrStatusBar :: Builder -> String -> IO () putStrStatusBar builder msg = do bar <- builderGetObject builder castToStatusbar _NAME_STATUS_BAR @@ -282,404 +313,414 @@ return () +-- | +-- +-- +putStrLnConsoleAsync :: Builder -> String -> IO () +putStrLnConsoleAsync builder msg = addCallback f >> return () + where + f = putStrLnConsole builder msg >> return False + + + -- |===================================================================== -- Dialog -- - --- | --- --- -getNameByFolderTreeDialog :: Builder -> String -> String -> String -> Bool -> IO (Maybe String) -getNameByFolderTreeDialog builder title msg value isEnabled = do - dialog <- builderGetObject builder castToDialog "TreeFolderCreateFolderDialog" - entry <- builderGetObject builder castToEntry "TreeFolderCreateFolderEntry" - label <- builderGetObject builder castToLabel "TreeFolderCreateFolderLabel" - - entrySetText entry value - set dialog [windowTitle := title] - set entry [entryEditable := isEnabled] - - if isEnabled then widgetShowAll entry else widgetHide entry - - labelSetText label msg - - res <- dialogRun dialog >>= \case - ResponseUser 0 -> do - name <- entryGetText entry - return $ if null name then Nothing else Just name - _ -> return Nothing - + +-- | +-- +-- +getNameByFolderTreeDialog :: Builder -> String -> String -> String -> Bool -> IO (Maybe String) +getNameByFolderTreeDialog builder title msg value isEnabled = do + dialog <- builderGetObject builder castToDialog "TreeFolderCreateFolderDialog" + entry <- builderGetObject builder castToEntry "TreeFolderCreateFolderEntry" + label <- builderGetObject builder castToLabel "TreeFolderCreateFolderLabel" + + entrySetText entry value + set dialog [windowTitle := title] + set entry [entryEditable := isEnabled] + + if isEnabled then widgetShowAll entry else widgetHide entry + + labelSetText label msg + + res <- dialogRun dialog >>= \case + ResponseUser 0 -> do + name <- entryGetText entry + return $ if null name then Nothing else Just name + _ -> return Nothing + widgetHide dialog - - return res - - --- | --- --- -getSearchKeyBySearchDialog :: Builder -> String -> IO (Maybe String) -getSearchKeyBySearchDialog builder defaultStr = do - dialog <- builderGetObject builder castToDialog "SearchDialog" - entry <- builderGetObject builder castToEntry "SearchDialogEntry" + + return res + + +-- | +-- +-- +getSearchKeyBySearchDialog :: Builder -> String -> IO (Maybe String) +getSearchKeyBySearchDialog builder defaultStr = do + dialog <- builderGetObject builder castToDialog "SearchDialog" + entry <- builderGetObject builder castToEntry "SearchDialogEntry" entrySetText entry defaultStr - widgetGrabFocus entry - res <- dialogRun dialog >>= \case - ResponseUser 0 -> do - value <- entryGetText entry - return $ if null value then Nothing else Just value - _ -> return Nothing - + widgetGrabFocus entry + res <- dialogRun dialog >>= \case + ResponseUser 0 -> do + value <- entryGetText entry + return $ if null value then Nothing else Just value + _ -> return Nothing + widgetHide dialog - - return res --- | --- --- -getSearchKeyFromSearchDialog :: Builder -> IO String -getSearchKeyFromSearchDialog builder = do - entry <- builderGetObject builder castToEntry "SearchDialogEntry" + return res + +-- | +-- +-- +getSearchKeyFromSearchDialog :: Builder -> IO String +getSearchKeyFromSearchDialog builder = do + entry <- builderGetObject builder castToEntry "SearchDialogEntry" entryGetText entry - --- | --- --- -getReplaceByReplaceDialog :: Builder -> IO (Maybe (String, String)) -getReplaceByReplaceDialog builder = do + +-- | +-- +-- +getReplaceByReplaceDialog :: Builder -> IO (Maybe (String, String)) +getReplaceByReplaceDialog builder = do initReplaceDialog builder - dialog <- builderGetObject builder castToDialog "ReplaceDialog" - searchEntry <- builderGetObject builder castToEntry "ReplaceDialogSearchEntry" - replaceEntry <- builderGetObject builder castToEntry "ReplaceDialogReplaceEntry" - - res <- dialogRun dialog >>= \case - ResponseUser 0 -> do - searchVal <- entryGetText searchEntry - replaceVal <- entryGetText replaceEntry - getResult searchVal replaceVal - _ -> return Nothing - - widgetHide dialog - return res - - where - getResult sVal rVal - | null sVal && null rVal = return Nothing - | otherwise = return $ Just (sVal, rVal) + dialog <- builderGetObject builder castToDialog "ReplaceDialog" + searchEntry <- builderGetObject builder castToEntry "ReplaceDialogSearchEntry" + replaceEntry <- builderGetObject builder castToEntry "ReplaceDialogReplaceEntry" --- | --- --- + res <- dialogRun dialog >>= \case + ResponseUser 0 -> do + searchVal <- entryGetText searchEntry + replaceVal <- entryGetText replaceEntry + getResult searchVal replaceVal + _ -> return Nothing + + widgetHide dialog + return res + + where + getResult sVal rVal + | null sVal && null rVal = return Nothing + | otherwise = return $ Just (sVal, rVal) + +-- | +-- +-- initSearchDialog :: Builder -> IO () initSearchDialog builder = do - entry <- builderGetObject builder castToEntry "SearchDialogEntry" - entrySetText entry "" + entry <- builderGetObject builder castToEntry "SearchDialogEntry" + entrySetText entry "" --- | --- --- +-- | +-- +-- initReplaceDialog :: Builder -> IO () initReplaceDialog builder = do - searchEntry <- builderGetObject builder castToEntry "ReplaceDialogSearchEntry" - replaceEntry <- builderGetObject builder castToEntry "ReplaceDialogReplaceEntry" - entrySetText searchEntry "" - entrySetText replaceEntry "" + searchEntry <- builderGetObject builder castToEntry "ReplaceDialogSearchEntry" + replaceEntry <- builderGetObject builder castToEntry "ReplaceDialogReplaceEntry" + entrySetText searchEntry "" + entrySetText replaceEntry "" -- |===================================================================== -- -- - --- | --- --- -setupToolButton :: Builder - -> DebugStartBTClickedEventHandler - -> DebugStopBTClickedEventHandler - -> StepOverBTClickedEventHandler - -> StepInBTClickedEventHandler - -> ContinueBTClickedEventHandler - -> BuildBTClickedEventHandler - -> SaveBTClickedEventHandler - -> IndentBTClickedEventHandler - -> UnIndentBTClickedEventHandler - -> CommentBTClickedEventHandler - -> UnCommentBTClickedEventHandler - -> StartGHCiBTClickedEventHandler - -> StopGHCiBTClickedEventHandler - -> IO () -setupToolButton builder debugStartEvh debugStopEvh stepOverEvh stepInEvh continueEvh buildEvh saveEvh indentEvh unIndentEvh commentEvh unCommentEvh startGHCi stopGHCi= do - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_SAVE - onToolButtonClicked bt saveEvh + +-- | +-- +-- +setupToolButton :: Builder + -> DebugStartBTClickedEventHandler + -> DebugStopBTClickedEventHandler + -> StepOverBTClickedEventHandler + -> StepInBTClickedEventHandler + -> ContinueBTClickedEventHandler + -> BuildBTClickedEventHandler + -> SaveBTClickedEventHandler + -> IndentBTClickedEventHandler + -> UnIndentBTClickedEventHandler + -> CommentBTClickedEventHandler + -> UnCommentBTClickedEventHandler + -> StartGHCiBTClickedEventHandler + -> StopGHCiBTClickedEventHandler + -> IO () +setupToolButton builder debugStartEvh debugStopEvh stepOverEvh stepInEvh continueEvh buildEvh saveEvh indentEvh unIndentEvh commentEvh unCommentEvh startGHCi stopGHCi= do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_SAVE + onToolButtonClicked bt saveEvh widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - onToolButtonClicked bt buildEvh + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD + onToolButtonClicked bt buildEvh widgetSetSensitive bt True - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI - onToolButtonClicked bt startGHCi + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + onToolButtonClicked bt startGHCi widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI - onToolButtonClicked bt stopGHCi + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + onToolButtonClicked bt stopGHCi widgetSetSensitive bt False ------------------------------------ - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - onToolButtonClicked bt debugStartEvh + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + onToolButtonClicked bt debugStartEvh widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - onToolButtonClicked bt debugStopEvh + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + onToolButtonClicked bt debugStopEvh widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - onToolButtonClicked bt continueEvh + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + onToolButtonClicked bt continueEvh widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - onToolButtonClicked bt stepOverEvh + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + onToolButtonClicked bt stepOverEvh widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN - onToolButtonClicked bt stepInEvh + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + onToolButtonClicked bt stepInEvh widgetSetSensitive bt False - + ------------------------------------ - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_INDENT - onToolButtonClicked bt indentEvh + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_INDENT + onToolButtonClicked bt indentEvh widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNINDENT - onToolButtonClicked bt unIndentEvh + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNINDENT + onToolButtonClicked bt unIndentEvh widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_COMMENT - onToolButtonClicked bt commentEvh + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_COMMENT + onToolButtonClicked bt commentEvh widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNCOMMENT - onToolButtonClicked bt unCommentEvh + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNCOMMENT + onToolButtonClicked bt unCommentEvh widgetSetSensitive bt True --- | --- --- -changeTBsOnGHCiStartting :: Builder -> IO () -changeTBsOnGHCiStartting builder = do +-- | +-- +-- +changeTBsOnGHCiStartting :: Builder -> IO () +changeTBsOnGHCiStartting builder = do - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt False --- | --- --- -changeTBsOnGHCiStarted :: Builder -> IO () -changeTBsOnGHCiStarted builder = do + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + +-- | +-- +-- +changeTBsOnGHCiStarted :: Builder -> IO () +changeTBsOnGHCiStarted builder = do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt True - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN - widgetSetSensitive bt False - - --- | --- --- -changeTBsOnGHCiStopped :: Builder -> IO () -changeTBsOnGHCiStopped builder = do - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt True + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + widgetSetSensitive bt False + + +-- | +-- +-- +changeTBsOnGHCiStopped :: Builder -> IO () +changeTBsOnGHCiStopped builder = do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + widgetSetSensitive bt True + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + widgetSetSensitive bt False - --- | --- --- -changeTBsOnBuildStart :: Builder -> IO () -changeTBsOnBuildStart builder = do - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN +-- | +-- +-- +changeTBsOnBuildStart :: Builder -> IO () +changeTBsOnBuildStart builder = do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False - --- | --- --- -changeTBsOnBuildFinish :: Builder -> IO () -changeTBsOnBuildFinish builder = do - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + widgetSetSensitive bt False + +-- | +-- +-- +changeTBsOnBuildFinish :: Builder -> IO () +changeTBsOnBuildFinish builder = do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + widgetSetSensitive bt True + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt False --- | --- --- -changeTBsOnDebugStarted :: Builder -> IO () -changeTBsOnDebugStarted builder = do - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + +-- | +-- +-- +changeTBsOnDebugStarted :: Builder -> IO () +changeTBsOnDebugStarted builder = do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt True - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt True + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt True - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN - widgetSetSensitive bt True + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + widgetSetSensitive bt True - --- | --- --- -changeTBsOnDebugStopped :: Builder -> IO () -changeTBsOnDebugStopped builder = do - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + widgetSetSensitive bt True + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + widgetSetSensitive bt True + + +-- | +-- +-- +changeTBsOnDebugStopped :: Builder -> IO () +changeTBsOnDebugStopped builder = do + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START - widgetSetSensitive bt True - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE - widgetSetSensitive bt False + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START + widgetSetSensitive bt True - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER - widgetSetSensitive bt False - - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN - widgetSetSensitive bt False - + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER + widgetSetSensitive bt False + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN + widgetSetSensitive bt False + diff --git a/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs b/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs --- a/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs +++ b/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs @@ -7,213 +7,201 @@ {-# LANGUAGE DeriveDataTypeable #-} module Phoityne.IO.GUI.GTK.SearchResultTable ( - SearchResultListStore + SearchResultListStore , SearchResultOffset -, SearchResultData(..) -, SearchResultTableDoubleClickedHandler -, createSearchResultListStore -, setupSearchResultTable -, addSearchReslutTable -, clearSearchResultTable -, activateSearchResultTab -, prevCurrentSearchResult -, nextCurrentSearchResult -, getCurrentSearchResult +, SearchResultData(..) +, SearchResultTableDoubleClickedHandler +, createSearchResultListStore +, setupSearchResultTable +, addSearchReslutTable +, clearSearchResultTable +, activateSearchResultTab +, prevCurrentSearchResult +, nextCurrentSearchResult +, getCurrentSearchResult ) where - + -- モジュール -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility -import Phoityne.Constant - --- システム -import Graphics.UI.Gtk -import System.Log.Logger +import Phoityne.IO.GUI.GTK.Constant +import Phoityne.Constant + +-- システム +import Graphics.UI.Gtk +import System.Log.Logger import Control.Monad.IO.Class -- | --- --- -data SearchResultData = SearchResultData { - filePathSearchResultData :: String - , lineNoSearchResultData :: Int - , startColSearchResultData :: Int - , endColSearchResultData :: Int - , lineSearchResultData :: String - } deriving (Show, Read, Eq, Ord) +-- +-- +data SearchResultData = SearchResultData { + filePathSearchResultData :: String + , lineNoSearchResultData :: Int + , startColSearchResultData :: Int + , endColSearchResultData :: Int + , lineSearchResultData :: String + } deriving (Show, Read, Eq, Ord) -- | --- --- +-- +-- type SearchResultOffset = (FilePath, Int) --- | --- +-- | -- -type SearchResultListStore = ListStore SearchResultData - - --- | --- --- -type SearchResultTableDoubleClickedHandler = SearchResultData -> IO () +-- +type SearchResultListStore = ListStore SearchResultData - --- | --- --- -createSearchResultListStore :: IO SearchResultListStore + +-- | +-- +-- +type SearchResultTableDoubleClickedHandler = SearchResultData -> IO () + + +-- | +-- +-- +createSearchResultListStore :: IO SearchResultListStore createSearchResultListStore = listStoreNew ([] :: [SearchResultData]) - - --- | --- --- + + +-- | +-- +-- setupSearchResultTable :: Builder -> SearchResultListStore -> SearchResultTableDoubleClickedHandler - -> IO () -setupSearchResultTable builder store evh = do - - treeView <- builderGetObject builder castToTreeView "SearchResultTreeView" - - col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewFilePathColumn" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := filePathSearchResultData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewLineNoColumn" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := show (lineNoSearchResultData cell) - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewStartColColumn" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := show (startColSearchResultData cell) - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewEndColColumn" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := show (endColSearchResultData cell) - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewLineColumn" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := lineSearchResultData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - - _ <- on treeView buttonPressEvent $ searchResultTableDoubleClickedHandler treeView store evh - - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle + -> IO () +setupSearchResultTable builder store evh = do - bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEL_SEARCH - onToolButtonClicked bt $ delSearchBTClickedEventHandler builder store - - setFont treeView - widgetShowAll treeView - --- | --- --- -searchResultTableDoubleClickedHandler :: TreeView -> ListStore SearchResultData -> SearchResultTableDoubleClickedHandler -> EventM EButton Bool -searchResultTableDoubleClickedHandler self listStore evh = eventClick >>= \case - DoubleClick -> do - liftIO $ do - - sel <- treeViewGetSelection self - treeSelectionGetSelected sel >>= \case - Nothing -> return False - Just iter -> do - let idx = listStoreIterToIndex iter - bpDat <- listStoreGetValue listStore idx - evh bpDat - return False - - _ -> return False - + treeView <- builderGetObject builder castToTreeView "SearchResultTreeView" --- | --- + col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewFilePathColumn" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := filePathSearchResultData cell + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewLineNoColumn" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := show (lineNoSearchResultData cell) + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewStartColColumn" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := show (startColSearchResultData cell) + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewEndColColumn" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := show (endColSearchResultData cell) + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("SearchResultTreeViewLineColumn" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := lineSearchResultData cell + ] + _ <- treeViewSetModel treeView store + + + _ <- on treeView buttonPressEvent $ searchResultTableDoubleClickedHandler treeView store evh + + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEL_SEARCH + onToolButtonClicked bt $ delSearchBTClickedEventHandler builder store + + widgetShowAll treeView + +-- | -- +-- +searchResultTableDoubleClickedHandler :: TreeView -> ListStore SearchResultData -> SearchResultTableDoubleClickedHandler -> EventM EButton Bool +searchResultTableDoubleClickedHandler self listStore evh = eventClick >>= \case + DoubleClick -> do + liftIO $ do + + sel <- treeViewGetSelection self + treeSelectionGetSelected sel >>= \case + Nothing -> return False + Just iter -> do + let idx = listStoreIterToIndex iter + bpDat <- listStoreGetValue listStore idx + evh bpDat + return False + + _ -> return False + + +-- | +-- +-- delSearchBTClickedEventHandler :: Builder -> ListStore SearchResultData -> IO () delSearchBTClickedEventHandler _ store = do -- initSearchDialog builder -- initReplaceDialog builder clearSearchResultTable store - --- | --- --- -activateSearchResultTab :: Builder -> IO () -activateSearchResultTab builder = do - child <- builderGetObject builder castToWidget "SearchResultBox" - note <- builderGetObject builder castToNotebook "RightSubNote" - - idx <- get note $ notebookChildPosition child + +-- | +-- +-- +activateSearchResultTab :: Builder -> IO () +activateSearchResultTab builder = do + child <- builderGetObject builder castToWidget "SearchResultBox" + note <- builderGetObject builder castToNotebook "RightSubNote" + + idx <- get note $ notebookChildPosition child notebookSetCurrentPage note idx -- | --- --- -addSearchReslutTable :: ListStore SearchResultData -> SearchResultData -> IO () -addSearchReslutTable store dat = listStoreAppend store dat >> return () - +-- +-- +addSearchReslutTable :: ListStore SearchResultData -> SearchResultData -> IO () +addSearchReslutTable store dat = listStoreAppend store dat >> return () + -- | --- --- -clearSearchResultTable :: ListStore SearchResultData -> IO () -clearSearchResultTable = listStoreClear - +-- +-- +clearSearchResultTable :: ListStore SearchResultData -> IO () +clearSearchResultTable = listStoreClear + -- | --- --- -prevCurrentSearchResult :: Builder -> ListStore SearchResultData -> IO () -prevCurrentSearchResult = undefined - +-- +-- +prevCurrentSearchResult :: Builder -> ListStore SearchResultData -> IO () +prevCurrentSearchResult = undefined + -- | --- --- -nextCurrentSearchResult :: Builder -> ListStore SearchResultData -> Maybe SearchResultOffset -> IO () -nextCurrentSearchResult builder store offset = do - treeView <- builderGetObject builder castToTreeView "SearchResultTreeView" - modelMay <- treeViewGetModel treeView +-- +-- +nextCurrentSearchResult :: Builder -> ListStore SearchResultData -> Maybe SearchResultOffset -> IO () +nextCurrentSearchResult builder store offset = do + treeView <- builderGetObject builder castToTreeView "SearchResultTreeView" + modelMay <- treeViewGetModel treeView nextCurrentSearchResultWithModel treeView store modelMay offset - - + + -- | --- --- -nextCurrentSearchResultWithModel :: TreeView -> ListStore SearchResultData -> Maybe TreeModel -> Maybe SearchResultOffset -> IO () -nextCurrentSearchResultWithModel _ _ Nothing _ = errorM _LOG_NAME $ "[nextCurrentSearchResultWithModel] invalid search result tree view." +-- +-- +nextCurrentSearchResultWithModel :: TreeView -> ListStore SearchResultData -> Maybe TreeModel -> Maybe SearchResultOffset -> IO () +nextCurrentSearchResultWithModel _ _ Nothing _ = errorM _LOG_NAME $ "[nextCurrentSearchResultWithModel] invalid search result tree view." nextCurrentSearchResultWithModel treeView store (Just model) (Just (path, lineNo))= do sel <- treeViewGetSelection treeView treeModelGetIterFirst model >>= \case @@ -223,7 +211,7 @@ Just curIter -> do treeSelectionSelectIter sel curIter treePath <- treeModelGetPath model curIter - treeViewScrollToCell treeView (Just treePath) Nothing Nothing + treeViewScrollToCell treeView (Just treePath) Nothing Nothing where findIter iter = do @@ -233,55 +221,55 @@ Nothing -> return Nothing Just nextIter -> findIter nextIter -nextCurrentSearchResultWithModel treeView _ (Just model) Nothing = do - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case - Nothing -> treeModelGetIterFirst model >>= \case - Nothing -> return () - Just firstIter -> treeSelectionSelectIter sel firstIter - - Just iter -> do - treeModelIterNext model iter >>= \case - Nothing -> treeModelGetIterFirst model >>= \case - Nothing -> return () - Just firstIter -> treeSelectionSelectIter sel firstIter +nextCurrentSearchResultWithModel treeView _ (Just model) Nothing = do + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case + Nothing -> treeModelGetIterFirst model >>= \case + Nothing -> return () + Just firstIter -> treeSelectionSelectIter sel firstIter + + Just iter -> do + treeModelIterNext model iter >>= \case + Nothing -> treeModelGetIterFirst model >>= \case + Nothing -> return () + Just firstIter -> treeSelectionSelectIter sel firstIter Just nextIter -> do - treeSelectionSelectIter sel nextIter + treeSelectionSelectIter sel nextIter treePath <- treeModelGetPath model nextIter - treeViewScrollToCell treeView (Just treePath) Nothing Nothing - + treeViewScrollToCell treeView (Just treePath) Nothing Nothing + -- | --- --- -getCurrentSearchResult :: Builder -> ListStore SearchResultData -> IO (Maybe SearchResultData) -getCurrentSearchResult builder store = do - getCurrentSearchResultIter builder store >>= \case - Nothing -> return Nothing - Just iter -> Just <$> listStoreGetValue store (listStoreIterToIndex iter) - +-- +-- +getCurrentSearchResult :: Builder -> ListStore SearchResultData -> IO (Maybe SearchResultData) +getCurrentSearchResult builder store = do + getCurrentSearchResultIter builder store >>= \case + Nothing -> return Nothing + Just iter -> Just <$> listStoreGetValue store (listStoreIterToIndex iter) + -- | --- --- -getCurrentSearchResultIter :: Builder -> ListStore SearchResultData -> IO (Maybe TreeIter) -getCurrentSearchResultIter builder store = do - treeView <- builderGetObject builder castToTreeView "SearchResultTreeView" - modelMay <- treeViewGetModel treeView - getCurrentSearchResultIterWithModel treeView store modelMay - +-- +-- +getCurrentSearchResultIter :: Builder -> ListStore SearchResultData -> IO (Maybe TreeIter) +getCurrentSearchResultIter builder store = do + treeView <- builderGetObject builder castToTreeView "SearchResultTreeView" + modelMay <- treeViewGetModel treeView + getCurrentSearchResultIterWithModel treeView store modelMay + -- | --- --- -getCurrentSearchResultIterWithModel :: TreeView -> ListStore SearchResultData -> Maybe TreeModel -> IO (Maybe TreeIter) +-- +-- +getCurrentSearchResultIterWithModel :: TreeView -> ListStore SearchResultData -> Maybe TreeModel -> IO (Maybe TreeIter) getCurrentSearchResultIterWithModel _ _ Nothing = do errorM _LOG_NAME $ "[getCurrentSearchResultIterWithModel] invalid search result tree view." - return Nothing -getCurrentSearchResultIterWithModel treeView _ (Just model) = do - sel <- treeViewGetSelection treeView - treeSelectionGetSelected sel >>= \case - Just iter -> return $ Just iter - Nothing -> treeModelGetIterFirst model >>= \case - Nothing -> return Nothing - Just firstIter -> do - treeSelectionSelectIter sel firstIter - return $ Just firstIter - + return Nothing +getCurrentSearchResultIterWithModel treeView _ (Just model) = do + sel <- treeViewGetSelection treeView + treeSelectionGetSelected sel >>= \case + Just iter -> return $ Just iter + Nothing -> treeModelGetIterFirst model >>= \case + Nothing -> return Nothing + Just firstIter -> do + treeSelectionSelectIter sel firstIter + return $ Just firstIter + diff --git a/app/Phoityne/IO/GUI/GTK/TextEditor.hs b/app/Phoityne/IO/GUI/GTK/TextEditor.hs --- a/app/Phoityne/IO/GUI/GTK/TextEditor.hs +++ b/app/Phoityne/IO/GUI/GTK/TextEditor.hs @@ -7,19 +7,19 @@ {-# LANGUAGE DeriveDataTypeable #-} module Phoityne.IO.GUI.GTK.TextEditor ( - TextEditorData(..) -, LineTextDoubleClickedHandler -, CodeNoteCloseEventHandler + TextEditorData(..) +, LineTextDoubleClickedHandler +, CodeNoteCloseEventHandler , CodeTextKeyPressEventHandler , CodeBufferChangedEventHandler , CodeBufferDeleteRangeEventHandler , CodeBufferInsertTextEventHandler -, setupCodeNote -, activateCodeNote -, highLightBreakPoint -, addBreakPointTagAtLine -, isCurrentTextEditor -, getCodeViewContent +, setupCodeNote +, activateCodeNote +, highLightBreakPoint +, addBreakPointTagAtLine +, isCurrentTextEditor +, getCodeViewContent , isTextEditorModified , setTextEditorModified , getCodeTextLineNumber @@ -32,81 +32,81 @@ , deleteRangeOnTextEditor , insertText2TextEditor , getSelectedText -, deleteBreakPointTag -, deleteBreakPointTagAtLine +, deleteBreakPointTag +, deleteBreakPointTagAtLine , updateBreakPointTag -, searchEndIter +, searchEndIter ) where - + -- モジュール -import Phoityne.Constant -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility - --- システム -import System.Log.Logger -import GHC.Float -import Graphics.UI.Gtk -import Control.Monad -import Control.Monad.IO.Class +import Phoityne.Constant +import Phoityne.IO.GUI.GTK.Constant +import Phoityne.IO.GUI.GTK.Utility + +-- システム +import System.Log.Logger +import GHC.Float +import Graphics.UI.Gtk +import Control.Monad +import Control.Monad.IO.Class import Data.String.Utils import qualified Control.Exception as E -import qualified Data.Text as T -import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.ByteString as BS -- | --- +-- -- -type LineTextDoubleClickedHandler - = Bool -- isTagExists - -> Int -- lineNo - -> IO () +type LineTextDoubleClickedHandler + = Bool -- isTagExists + -> Int -- lineNo + -> IO () -- | --- +-- -- -type HSCode = BS.ByteString +type HSCode = BS.ByteString -- | --- +-- -- type CodeNoteCloseEventHandler = TextEditorData -> IO () - + -- | --- --- -data TextEditorData = +-- +-- +data TextEditorData = TextEditorData { - lineTextEditorData :: TextView - , codeTextEditorData :: TextView - , boxTextEditorData :: HBox - , tabLabelTextEditorData :: Label + lineTextEditorData :: TextView + , codeTextEditorData :: TextView + , boxTextEditorData :: HBox + , tabLabelTextEditorData :: Label } deriving (Eq) -- | --- --- -type CodeTextKeyPressEventHandler = String -> Bool -> Bool -> Bool -> Int -> IO Bool +-- +-- +type CodeTextKeyPressEventHandler = String -> Bool -> Bool -> Bool -> Int -> IO Bool -- | --- --- -type CodeBufferChangedEventHandler = IO () +-- +-- +type CodeBufferChangedEventHandler = IO () -- | --- --- -type CodeBufferDeleteRangeEventHandler = (Int, Int) -> (Int, Int) -> String -> IO () +-- +-- +type CodeBufferDeleteRangeEventHandler = (Int, Int) -> (Int, Int) -> String -> IO () -- | --- --- -type CodeBufferInsertTextEventHandler = (Int, Int) -> String -> IO () +-- +-- +type CodeBufferInsertTextEventHandler = (Int, Int) -> String -> IO () - --- | --- + +-- | -- +-- searchEndIter :: TextEditorData -> Int -> Int -> String -> IO (Int, Int) searchEndIter (TextEditorData _ codeView _ _) startLineNo startColNo str = do buf <- textViewGetBuffer codeView @@ -118,67 +118,59 @@ -- | --- --- -setupCodeNote :: Builder - -> String -- ファイル名 - -> FilePath -- ファイルパス - -> HSCode -- コンテンツ - -> CodeNoteCloseEventHandler - -> LineTextDoubleClickedHandler +-- +-- +setupCodeNote :: Builder + -> String -- ファイル名 + -> FilePath -- ファイルパス + -> HSCode -- コンテンツ + -> CodeNoteCloseEventHandler + -> LineTextDoubleClickedHandler -> Maybe Int -- スクロールライン -> CodeTextKeyPressEventHandler - -> CodeBufferChangedEventHandler + -> CodeBufferChangedEventHandler -> CodeBufferDeleteRangeEventHandler -> CodeBufferInsertTextEventHandler - -> IO TextEditorData -setupCodeNote builder name path code evh lineViewEvh _ codeKeyEVH bufEVH delRangeEVH insertTextEVH = do + -> IO TextEditorData +setupCodeNote builder name path code evh lineViewEvh _ codeKeyEVH bufEVH delRangeEVH insertTextEVH = do img <- imageNewFromIcon (T.pack "window-close") 8 - withIcon img + withIcon img where withIcon Nothing = do criticalM _LOG_NAME $ "[setupCodeNote] close icon not found." - E.throwIO . userError $ "[setupCodeNote] close icon not found." - withIcon (Just image) = do - -- ページタブのラベルとクローズボタンの生成 - box <- hBoxNew False 0 - label <- labelNew $ Just name - - fontDesc <- fontDescriptionNew - fontDescriptionSetFamily fontDesc (_FONT_DESC) - fontDescriptionSetSize fontDesc 9 - widgetOverrideFont label $ Just fontDesc - - closeButton <- toolButtonNew (Just image) (Nothing::Maybe T.Text) - - boxPackStart box label PackNatural 0 - boxPackStart box closeButton PackNatural 0 - widgetShowAll box - - menuWidget <- labelNew $ Just path - widgetOverrideFont menuWidget $ Just fontDesc - - -- ノートブックに新規ページの生成 + E.throwIO . userError $ "[setupCodeNote] close icon not found." + withIcon (Just image) = do + -- ページタブのラベルとクローズボタンの生成 + box <- hBoxNew False 0 + label <- labelNew $ Just name + + closeButton <- toolButtonNew (Just image) (Nothing::Maybe T.Text) + + boxPackStart box label PackNatural 0 + boxPackStart box closeButton PackNatural 0 + widgetShowAll box + + menuWidget <- labelNew $ Just path + + -- ノートブックに新規ページの生成 note <- builderGetObject builder castToNotebook _NAME_CODE_NOTE - textEditor <- createTextEditor builder code lineViewEvh label codeKeyEVH bufEVH delRangeEVH insertTextEVH - - _ <- notebookAppendPageMenu note (boxTextEditorData textEditor) box menuWidget - - notebookSetTabReorderable note (boxTextEditorData textEditor) True - - _ <- onToolButtonClicked closeButton (codeNoteCloseEventHandler note textEditor evh) + textEditor <- createTextEditor builder code lineViewEvh label codeKeyEVH bufEVH delRangeEVH insertTextEVH - setFont note + _ <- notebookPrependPageMenu note (boxTextEditorData textEditor) box menuWidget - widgetShowAll note + notebookSetTabReorderable note (boxTextEditorData textEditor) True + _ <- onToolButtonClicked closeButton (codeNoteCloseEventHandler note textEditor evh) + + widgetShowAll note + return textEditor - --- | --- --- + +-- | +-- +-- createTextEditor :: Builder -> HSCode -> LineTextDoubleClickedHandler @@ -187,113 +179,110 @@ -> CodeBufferChangedEventHandler -> CodeBufferDeleteRangeEventHandler -> CodeBufferInsertTextEventHandler - -> IO TextEditorData -createTextEditor builder code evh tabLabel codeKeyEVH bufEVH delRangeEVH insertTextEVH = do - + -> IO TextEditorData +createTextEditor builder code evh tabLabel codeKeyEVH bufEVH delRangeEVH insertTextEVH = do + tagTable <- builderGetObject builder castToTextTagTable _NAME_TAG_TABLE - lineBuf <- textBufferNew $ Just tagTable - codeBuf <- textBufferNew $ Just tagTable - lineTextView <- textViewNewWithBuffer lineBuf - codeTextView <- textViewNewWithBuffer codeBuf - - textTagTableLookup tagTable (T.unpack _BREAK_POINT_HIGHLIGHT_TAG) >>= \case - Just _ -> return () - Nothing -> do - tag <- textTagNew (Just _BREAK_POINT_HIGHLIGHT_TAG) - set tag [textTagBackground := "blue", textTagForeground := "white", textTagBackgroundSet := True] - textTagTableAdd tagTable tag - - box <- hBoxNew False 0 - - lineScroll <- scrolledWindowNew Nothing Nothing - scrolledWindowSetPlacement lineScroll CornerTopRight - - codeScroll <- scrolledWindowNew Nothing Nothing - - ajust <- scrolledWindowGetVAdjustment codeScroll - scrolledWindowSetVAdjustment lineScroll ajust - set lineScroll [ scrolledWindowHscrollbarPolicy := PolicyNever - , scrolledWindowVscrollbarPolicy := PolicyAutomatic] - - textViewSetBorderWindowSize codeTextView TextWindowTop 5 - textViewSetBorderWindowSize codeTextView TextWindowBottom 5 - textViewSetBorderWindowSize codeTextView TextWindowLeft 5 - textViewSetBorderWindowSize codeTextView TextWindowRight 5 - - textViewSetBorderWindowSize lineTextView TextWindowTop 5 - textViewSetBorderWindowSize lineTextView TextWindowBottom 5 - --textViewSetBorderWindowSize lineTextView TextWindowLeft 10 - --textViewSetBorderWindowSize lineTextView TextWindowRight 5 - textViewSetEditable lineTextView False - textViewSetCursorVisible lineTextView False - textViewSetJustification lineTextView JustifyRight - - widgetModifyBg lineTextView StateNormal $ Color 0xd8d8 0xd8d8 0xd8d8 - - containerAdd lineScroll lineTextView - containerAdd codeScroll codeTextView - - boxPackStart box lineScroll PackNatural 0 - boxPackStart box codeScroll PackGrow 0 - - setFont lineTextView - setFont codeTextView - - _ <- on lineTextView buttonPressEvent $ lineTextDoubleClickedHandler lineTextView evh - - codeBuf <- textViewGetBuffer codeTextView - lineBuf <- textViewGetBuffer lineTextView - - textBufferSetByteString codeBuf code - lineCount <- textBufferGetLineCount codeBuf - + lineBuf <- textBufferNew $ Just tagTable + codeBuf <- textBufferNew $ Just tagTable + lineTextView <- textViewNewWithBuffer lineBuf + codeTextView <- textViewNewWithBuffer codeBuf + + textTagTableLookup tagTable (T.unpack _BREAK_POINT_HIGHLIGHT_TAG) >>= \case + Just _ -> return () + Nothing -> do + tag <- textTagNew (Just _BREAK_POINT_HIGHLIGHT_TAG) + set tag [textTagBackground := "blue", textTagForeground := "white", textTagBackgroundSet := True] + textTagTableAdd tagTable tag + + box <- hBoxNew False 0 + + lineScroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPlacement lineScroll CornerTopRight + + codeScroll <- scrolledWindowNew Nothing Nothing + + ajust <- scrolledWindowGetVAdjustment codeScroll + scrolledWindowSetVAdjustment lineScroll ajust + set lineScroll [ scrolledWindowHscrollbarPolicy := PolicyNever + , scrolledWindowVscrollbarPolicy := PolicyAutomatic] + + textViewSetBorderWindowSize codeTextView TextWindowTop 5 + textViewSetBorderWindowSize codeTextView TextWindowBottom 5 + textViewSetBorderWindowSize codeTextView TextWindowLeft 5 + textViewSetBorderWindowSize codeTextView TextWindowRight 5 + + textViewSetBorderWindowSize lineTextView TextWindowTop 5 + textViewSetBorderWindowSize lineTextView TextWindowBottom 5 + --textViewSetBorderWindowSize lineTextView TextWindowLeft 10 + --textViewSetBorderWindowSize lineTextView TextWindowRight 5 + textViewSetEditable lineTextView False + textViewSetCursorVisible lineTextView False + textViewSetJustification lineTextView JustifyRight + + --widgetModifyBg lineTextView StateNormal $ Color 0xd8d8 0xd8d8 0xd8d8 + + containerAdd lineScroll lineTextView + containerAdd codeScroll codeTextView + + boxPackStart box lineScroll PackNatural 0 + boxPackStart box codeScroll PackGrow 0 + + _ <- on lineTextView buttonPressEvent $ lineTextDoubleClickedHandler lineTextView evh + + codeBuf <- textViewGetBuffer codeTextView + lineBuf <- textViewGetBuffer lineTextView + + textBufferSetByteString codeBuf code + lineCount <- textBufferGetLineCount codeBuf + let lineStr = createLineNoText [1..lineCount] "" - textBufferSetText lineBuf lineStr - - fontDesc <- fontDescriptionNew - fontDescriptionSetFamily fontDesc (_FONT_DESC) - fontDescriptionSetSize fontDesc 9 - widgetOverrideFont (castToWidget lineTextView) $ Just fontDesc - widgetOverrideFont (castToWidget codeTextView) $ Just fontDesc - - {- - -- 行番号の垂直スクロールバーを消す。お試し。 - widgetSetSizeRequest (castToWidget lineScroll) 0 (-1) - scrolledWindowGetVScrollbar lineScroll >>= \case - Nothing -> return () - Just s -> widgetHide (castToWidget s) - -} - - saveBt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_SAVE - textBufferSetModified codeBuf False - _ <- on codeBuf bufferChanged $ codeTextBufferChangedHandler lineBuf codeBuf bufEVH - _ <- on codeBuf modifiedChanged $ codeTextModifiedHandler codeBuf tabLabel saveBt + textBufferSetText lineBuf lineStr + + fontDesc <- fontDescriptionNew + -- fontDescriptionSetFamily fontDesc (_FONT_DESC) + -- fontDescriptionSetSize fontDesc 9 + widgetOverrideFont (castToWidget lineTextView) $ Just fontDesc + widgetOverrideFont (castToWidget codeTextView) $ Just fontDesc + + {- + -- 行番号の垂直スクロールバーを消す。お試し。 + widgetSetSizeRequest (castToWidget lineScroll) 0 (-1) + scrolledWindowGetVScrollbar lineScroll >>= \case + Nothing -> return () + Just s -> widgetHide (castToWidget s) + -} + + saveBt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_SAVE + textBufferSetModified codeBuf False + _ <- on codeBuf bufferChanged $ codeTextBufferChangedHandler lineBuf codeBuf bufEVH + _ <- on codeBuf modifiedChanged $ codeTextModifiedHandler codeBuf tabLabel saveBt _ <- on codeTextView keyPressEvent $ codeTextKeyPressEventHandler lineTextView codeTextView codeKeyEVH _ <- on codeTextView buttonPressEvent $ codeTextButtonPressEventHandler codeTextView _ <- on codeBuf deleteRange $ codeTextDeleteRangeEventHandler codeTextView delRangeEVH _ <- on codeBuf bufferInsertText $ codeTextInsertTextEventHandler codeTextView insertTextEVH - return $ TextEditorData lineTextView codeTextView box tabLabel - + return $ TextEditorData lineTextView codeTextView box tabLabel + where createLineNoText [] acc = acc createLineNoText (x:[]) acc = acc ++ " " ++ show x ++ " " createLineNoText (x:xs) acc = acc ++ " " ++ show x ++ " \n" ++ createLineNoText xs acc - - codeTextModifiedHandler codeBuf label saveBt = do - textBufferGetModified codeBuf >>= \case - False -> do - str <- labelGetText label - labelSetText label $ init . init $ (str :: String) - widgetSetSensitive saveBt False - True -> do - str <- labelGetText label - labelSetText label $ str ++ (" *"::String) - widgetSetSensitive saveBt True + codeTextModifiedHandler codeBuf label saveBt = do + textBufferGetModified codeBuf >>= \case + False -> do + str <- labelGetText label + labelSetText label $ init . init $ (str :: String) + widgetSetSensitive saveBt False + True -> do + str <- labelGetText label + labelSetText label $ str ++ (" *"::String) + widgetSetSensitive saveBt True + codeTextBufferChangedHandler lineBuf codeBuf _ = do ll <- textBufferGetLineCount lineBuf - cl <- textBufferGetLineCount codeBuf + cl <- textBufferGetLineCount codeBuf updateLineNo lineBuf codeBuf ll cl updateLineNo lineBuf _ ll cl @@ -322,239 +311,225 @@ startLineNo <- textIterGetLine si startColNo <- textIterGetLineOffset si evh (startLineNo, startColNo) str - + -- | --- Event Handler --- -codeNoteCloseEventHandler :: Notebook -> TextEditorData -> CodeNoteCloseEventHandler -> IO () -codeNoteCloseEventHandler note wid evh = do - notebookPageNum note (boxTextEditorData wid) >>= \case - Just idx -> notebookRemovePage note idx - Nothing -> errorM _LOG_NAME $ "[codeNoteCloseEventHandler]unexpected error." - evh wid - - +-- Event Handler +-- +codeNoteCloseEventHandler :: Notebook -> TextEditorData -> CodeNoteCloseEventHandler -> IO () +codeNoteCloseEventHandler note wid evh = do + notebookPageNum note (boxTextEditorData wid) >>= \case + Just idx -> notebookRemovePage note idx + Nothing -> errorM _LOG_NAME $ "[codeNoteCloseEventHandler]unexpected error." + evh wid + + -- | --- --- -activateCodeNote :: Builder -> TextEditorData -> Int -> IO () -activateCodeNote builder wid lineNo = do +-- +-- +activateCodeNote :: Builder -> TextEditorData -> Int -> IO () +activateCodeNote builder wid lineNo = do note <- builderGetObject builder castToNotebook _NAME_CODE_NOTE - notebookPageNum note (boxTextEditorData wid) >>= \case - Just idx -> notebookSetCurrentPage note idx - Nothing -> errorM _LOG_NAME $ "[activateCodeNote]invalid node page." + notebookPageNum note (boxTextEditorData wid) >>= \case + Just idx -> notebookSetCurrentPage note idx + Nothing -> errorM _LOG_NAME $ "[activateCodeNote]invalid node page." - window <- builderGetObject builder castToWindow _WINDOW_NAME - widgetShowAll window - forceEvent - - let codeTextView = codeTextEditorData wid - codeBuf <- textViewGetBuffer codeTextView - iter <- textBufferGetIterAtLine codeBuf lineNo + window <- builderGetObject builder castToWindow _WINDOW_NAME + widgetShowAll window + forceEvent - isLineVisible wid lineNo >>= \case - True -> return () - False -> textViewScrollToIter codeTextView iter 0.0 (Just (0.0, 0.5)) >> return () + let codeTextView = codeTextEditorData wid + if 1 > lineNo then return () else do + isLineVisible wid lineNo >>= \case + True -> return () + False -> do + codeBuf <- textViewGetBuffer codeTextView + iter <- textBufferGetIterAtLine codeBuf lineNo + textViewScrollToIter codeTextView iter 0.0 (Just (0.0, 0.5)) >> return () + widgetGrabFocus codeTextView -- | --- Event Handler --- -lineTextDoubleClickedHandler :: TextView -> LineTextDoubleClickedHandler -> EventM EButton Bool -lineTextDoubleClickedHandler self evh = eventClick >>= \case - DoubleClick -> doubleClicked >> return True - _ -> return False - - where - doubleClicked = do - (_, posYd) <- eventCoordinates - liftIO $ do - scrollY <- textViewGetVadjustment self >>= adjustmentGetValue - let posY = scrollY + posYd - - (iter, _) <- textViewGetLineAtY self $ double2Int posY - isTagExists <- textIterBeginsTag iter Nothing - lineNo <- textIterGetLine iter +-- Event Handler +-- +lineTextDoubleClickedHandler :: TextView -> LineTextDoubleClickedHandler -> EventM EButton Bool +lineTextDoubleClickedHandler self evh = eventClick >>= \case + DoubleClick -> doubleClicked >> return True + _ -> return False + + where + doubleClicked = do + (_, posYd) <- eventCoordinates + liftIO $ do + scrollY <- textViewGetVadjustment self >>= adjustmentGetValue + let posY = scrollY + posYd + + (iter, _) <- textViewGetLineAtY self $ double2Int posY + isTagExists <- textIterBeginsTag iter Nothing + lineNo <- textIterGetLine iter evh isTagExists lineNo -- | --- --- +-- +-- updateBreakPointTag :: TextEditorData -> Bool -> Int -> IO () updateBreakPointTag (TextEditorData lineView _ _ _) True lineNo = deleteBreakPointTagAtLine lineView lineNo updateBreakPointTag (TextEditorData lineView _ _ _) False lineNo = addBreakPointTagAtLine lineView lineNo - + -- | --- --- -addBreakPointTagAtLine :: TextView -> Int -> IO () -addBreakPointTagAtLine self line = do - buf <- textViewGetBuffer self - iter <- textBufferGetIterAtLine buf line - addBreakPointTagAtIter self iter - +-- +-- +addBreakPointTagAtLine :: TextView -> Int -> IO () +addBreakPointTagAtLine self line = do + buf <- textViewGetBuffer self + iter <- textBufferGetIterAtLine buf line + addBreakPointTagAtIter self iter + -- | --- --- -addBreakPointTagAtIter :: TextView -> TextIter -> IO () -addBreakPointTagAtIter self startIter = do - textBuf <- textIterGetBuffer startIter - tagTable <- textBufferGetTagTable textBuf - - tag <- textTagNew Nothing - set tag [textTagBackground := "blue", textTagForeground := "white", textTagBackgroundSet := True] - textTagTableAdd tagTable tag - - endIter <- textIterCopy startIter - _ <- textViewForwardDisplayLineEnd self endIter - - textBufferApplyTag textBuf tag startIter endIter - - +-- +-- +addBreakPointTagAtIter :: TextView -> TextIter -> IO () +addBreakPointTagAtIter self startIter = do + textBuf <- textIterGetBuffer startIter + tagTable <- textBufferGetTagTable textBuf + + tag <- textTagNew Nothing + set tag [textTagBackground := "blue", textTagForeground := "white", textTagBackgroundSet := True] + textTagTableAdd tagTable tag + + endIter <- textIterCopy startIter + _ <- textViewForwardDisplayLineEnd self endIter + + textBufferApplyTag textBuf tag startIter endIter + + -- | --- 指定行についているタグをすべて削除する --- -deleteBreakPointTagAtLine :: TextView -> Int -> IO () -deleteBreakPointTagAtLine textView line = do - buf <- textViewGetBuffer textView - iter <- textBufferGetIterAtLine buf line - deleteBreakPointTagAtIter iter - +-- 指定行についているタグをすべて削除する +-- +deleteBreakPointTagAtLine :: TextView -> Int -> IO () +deleteBreakPointTagAtLine textView line = do + buf <- textViewGetBuffer textView + iter <- textBufferGetIterAtLine buf line + deleteBreakPointTagAtIter iter + -- | --- TextIterの位置についているタグをすべて削除する --- -deleteBreakPointTagAtIter :: TextIter -> IO () -deleteBreakPointTagAtIter iter = do - textBuf <- textIterGetBuffer iter - tagTable <- textBufferGetTagTable textBuf - tags <- textIterGetTags iter - mapM_ (textTagTableRemove tagTable) tags - +-- TextIterの位置についているタグをすべて削除する +-- +deleteBreakPointTagAtIter :: TextIter -> IO () +deleteBreakPointTagAtIter iter = do + textBuf <- textIterGetBuffer iter + tagTable <- textBufferGetTagTable textBuf + tags <- textIterGetTags iter + mapM_ (textTagTableRemove tagTable) tags + -- | --- --- -deleteBreakPointTag :: TextEditorData -> Int -> IO () -deleteBreakPointTag (TextEditorData lineView _ _ _) lineNo = do - textBuf <- textViewGetBuffer lineView - tagTable <- textBufferGetTagTable textBuf - iter <- textBufferGetIterAtLine textBuf (lineNo - 1) - tags <- textIterGetTags iter - mapM_ (textTagTableRemove tagTable) tags - +-- +-- +deleteBreakPointTag :: TextEditorData -> Int -> IO () +deleteBreakPointTag (TextEditorData lineView _ _ _) lineNo = do + textBuf <- textViewGetBuffer lineView + tagTable <- textBufferGetTagTable textBuf + iter <- textBufferGetIterAtLine textBuf (lineNo - 1) + tags <- textIterGetTags iter + mapM_ (textTagTableRemove tagTable) tags + -- | --- --- -highLightBreakPoint :: TextEditorData -> Int -> Int -> Int -> Int -> IO () -highLightBreakPoint textEditor sl sc el ec = do - - let codeTextView = codeTextEditorData textEditor - codeBuf <- textViewGetBuffer codeTextView - --tagTable <- textBufferGetTagTable codeBuf +-- +-- +highLightBreakPoint :: TextEditorData -> Int -> Int -> Int -> Int -> IO () +highLightBreakPoint textEditor sl sc el ec = do - startLine <- normalizeLine codeBuf sl + let codeTextView = codeTextEditorData textEditor + codeBuf <- textViewGetBuffer codeTextView + + startLine <- normalizeLine codeBuf sl startCol <- normalizeColumn codeBuf startLine sc - endLine <- normalizeLine codeBuf el + endLine <- normalizeLine codeBuf el endCol <- normalizeColumn codeBuf endLine ec - startIter <- textBufferGetIterAtLineOffset codeBuf startLine startCol - endIter <- textBufferGetIterAtLineOffset codeBuf endLine (endCol + 1) + debugM _LOG_NAME $ "range:(" ++ show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec ++ ")" + debugM _LOG_NAME $ "range normalized:(" ++ show startLine ++ ":" ++ show startCol ++ "-" ++ show endLine ++ ":" ++ show endCol ++ ")" - textBufferPlaceCursor codeBuf endIter - textBufferSelectRange codeBuf startIter endIter + withSelectable codeBuf startLine startCol endLine endCol where - normalizeLine buf l = do - nl <- normalizeLine_ buf l - return $ if 0 > nl then 0 else nl + withSelectable codeBuf startLine startCol endLine endCol + | (0 > startLine) || (0 > startCol) || (0 > endLine) ||(0 > endCol) = infoM _LOG_NAME "selection range not found." + | otherwise = do + startIter <- textBufferGetIterAtLineOffset codeBuf startLine startCol + endIter <- textBufferGetIterAtLineOffset codeBuf endLine (endCol + 1) + textBufferPlaceCursor codeBuf endIter + textBufferSelectRange codeBuf startIter endIter - normalizeLine_ buf l = do + normalizeLine buf l = do allLines <- textBufferGetLineCount buf - return $ if l > allLines then allLines - 1 else l - 1 + return $ if l > allLines then (-1) else l - 1 normalizeColumn buf line col = do - nc <- normalizeColumn_ buf line col - return $ if 0 > nc then 0 else nc - - normalizeColumn_ buf line col = do iter <- textBufferGetIterAtLine buf line - allChars <- textIterGetCharsInLine iter -- -1 for delimiters - let allChars' = allChars - 1 - return $ if col > allChars' then allChars' - 1 else col - 1 + allChars <- textIterGetCharsInLine iter + let allChars' = allChars - 1 -- sub LF + if 1 > allChars' then return (-1) + else if col > allChars' then return (allChars' - 1) + else return (col - 1) - --- | --- --- --- offLightBreakPoint :: TextEditorData -> IO () --- offLightBreakPoint textEditor = do - - -- let codeTextView = codeTextEditorData textEditor - -- codeBuf <- textViewGetBuffer codeTextView - -- - -- startIter <- textBufferGetStartIter codeBuf - -- endIter <- textBufferGetEndIter codeBuf - - -- textBufferRemoveTagByName codeBuf _BREAK_POINT_HIGHLIGHT_TAG startIter endIter - - -- return () - + -- | --- --- -isCurrentTextEditor :: Builder -> TextEditorData -> IO Bool -isCurrentTextEditor bulder (TextEditorData _ _ box _) = do - getCurrentTextEditorHBox bulder >>= \case - Nothing -> return False - Just b -> return $ box == b - +-- +-- +isCurrentTextEditor :: Builder -> TextEditorData -> IO Bool +isCurrentTextEditor bulder (TextEditorData _ _ box _) = do + getCurrentTextEditorHBox bulder >>= \case + Nothing -> return False + Just b -> return $ box == b + -- | --- --- -getCurrentTextEditorHBox :: Builder -> IO (Maybe HBox) -getCurrentTextEditorHBox builder = do - note <- builderGetObject builder castToNotebook _NAME_CODE_NOTE - - notebookGetCurrentPage note >>= \case - (-1) -> return Nothing - idx -> notebookGetNthPage note idx >>= \case - Nothing -> return Nothing - Just w -> return . Just $ castToHBox w - +-- +-- +getCurrentTextEditorHBox :: Builder -> IO (Maybe HBox) +getCurrentTextEditorHBox builder = do + note <- builderGetObject builder castToNotebook _NAME_CODE_NOTE + + notebookGetCurrentPage note >>= \case + (-1) -> return Nothing + idx -> notebookGetNthPage note idx >>= \case + Nothing -> return Nothing + Just w -> return . Just $ castToHBox w + -- | --- --- -getCodeViewContent :: TextEditorData -> IO BS.ByteString -getCodeViewContent (TextEditorData _ codeView _ _) = do - buf <- textViewGetBuffer codeView - textBufferSetModified buf False - startIter <- textBufferGetStartIter buf - endIter <- textBufferGetEndIter buf - textBufferGetByteString buf startIter endIter False - +-- +-- +getCodeViewContent :: TextEditorData -> IO BS.ByteString +getCodeViewContent (TextEditorData _ codeView _ _) = do + buf <- textViewGetBuffer codeView + textBufferSetModified buf False + startIter <- textBufferGetStartIter buf + endIter <- textBufferGetEndIter buf + textBufferGetByteString buf startIter endIter False + -- | --- --- -isTextEditorModified :: TextEditorData -> IO Bool -isTextEditorModified (TextEditorData _ codeView _ _) = do - buf <- textViewGetBuffer codeView - textBufferGetModified buf +-- +-- +isTextEditorModified :: TextEditorData -> IO Bool +isTextEditorModified (TextEditorData _ codeView _ _) = do + buf <- textViewGetBuffer codeView + textBufferGetModified buf -- | --- +-- -- setTextEditorModified :: TextEditorData -> Bool -> IO () -setTextEditorModified (TextEditorData _ codeView _ _) isModified = do - buf <- textViewGetBuffer codeView +setTextEditorModified (TextEditorData _ codeView _ _) isModified = do + buf <- textViewGetBuffer codeView textBufferSetModified buf isModified -- | --- +-- -- codeTextButtonPressEventHandler :: TextView -> EventM EButton Bool codeTextButtonPressEventHandler textView = eventButton >>= \case @@ -567,15 +542,15 @@ _ -> return False --- | --- Event Handler --- -codeTextKeyPressEventHandler :: TextView -> TextView -> CodeTextKeyPressEventHandler -> EventM EKey Bool -codeTextKeyPressEventHandler lineTextView codeTextView evh = do - name <- eventKeyName +-- | +-- Event Handler +-- +codeTextKeyPressEventHandler :: TextView -> TextView -> CodeTextKeyPressEventHandler -> EventM EKey Bool +codeTextKeyPressEventHandler lineTextView codeTextView evh = do + name <- eventKeyName mods <- eventModifier - - liftIO $ do + + liftIO $ do buf <- textViewGetBuffer codeTextView mark <- textBufferGetInsert buf iter <- textBufferGetIterAtMark buf mark @@ -587,11 +562,11 @@ evh (T.unpack name) (elem Shift mods) (elem Control mods) isTagExists lineNo --- | --- --- -getCodeTextLineNumber :: TextEditorData -> IO (Int, Int) -getCodeTextLineNumber (TextEditorData _ codeView _ _) = do +-- | +-- +-- +getCodeTextLineNumber :: TextEditorData -> IO (Int, Int) +getCodeTextLineNumber (TextEditorData _ codeView _ _) = do buf <- textViewGetBuffer codeView mark <- textBufferGetInsert buf iter <- textBufferGetIterAtMark buf mark @@ -599,9 +574,9 @@ colNo <- textIterGetLineOffset iter return (lineNo, colNo) --- | --- --- +-- | +-- +-- blockIndentTextEditor :: TextEditorData -> IO () blockIndentTextEditor te@(TextEditorData _ codeView _ _) = do (startLine, endLine) <- getSelectedLineNumbers te @@ -614,9 +589,9 @@ if lineNo == endNo then return () else insertIndent buf (lineNo+1) endNo --- | --- --- +-- | +-- +-- blockUnIndentTextEditor :: TextEditorData -> IO () blockUnIndentTextEditor te@(TextEditorData _ codeView _ _) = do (startLine, endLine) <- getSelectedLineNumbers te @@ -636,9 +611,9 @@ if lineNo == endNo then return () else deleteIndent buf (lineNo+1) endNo --- | --- --- +-- | +-- +-- blockCommentTextEditor :: TextEditorData -> IO () blockCommentTextEditor te@(TextEditorData _ codeView _ _) = do (startLine, endLine) <- getSelectedLineNumbers te @@ -667,9 +642,9 @@ str <- textBufferGetText buf iter endIter False return $ length $ takeWhile (== ' ') str --- | --- --- +-- | +-- +-- blockUnCommentTextEditor :: TextEditorData -> IO () blockUnCommentTextEditor te@(TextEditorData _ codeView _ _) = do (startLine, endLine) <- getSelectedLineNumbers te @@ -704,9 +679,9 @@ if startswith _COMMENT_TAG (strip str) then return (True, length (head (split _COMMENT_TAG str))) else return (False, length (takeWhile (== ' ') str)) --- | --- --- +-- | +-- +-- getSelectedLineNumbers :: TextEditorData -> IO (Int, Int) getSelectedLineNumbers te@(TextEditorData _ codeView _ _) = do buf <- textViewGetBuffer codeView @@ -720,18 +695,18 @@ (l, _) <- getCodeTextLineNumber te return (l, l) --- | --- --- +-- | +-- +-- setContent2TextEditor :: TextEditorData -> BS.ByteString -> IO () setContent2TextEditor (TextEditorData _ codeView _ _) bs = do buf <- textViewGetBuffer codeView textBufferSetByteString buf bs textBufferSetModified buf False --- | --- --- +-- | +-- +-- setCursorOnTextEditor :: TextEditorData -> Int -> Int -> IO () setCursorOnTextEditor ed@(TextEditorData _ codeView _ _) lineNo colNo = isLineVisible ed lineNo >>= \case True -> return () @@ -742,18 +717,18 @@ mark <- textBufferGetInsert buf textViewScrollToMark codeView mark 0.0 (Just (0.0, 0.5)) --- | --- +-- | -- +-- insertText2TextEditor :: TextEditorData -> Int -> Int -> String -> IO () insertText2TextEditor (TextEditorData _ codeView _ _) startLineNo startColNo str = do buf <- textViewGetBuffer codeView iter <- textBufferGetIterAtLineOffset buf startLineNo startColNo textBufferInsert buf iter str --- | --- +-- | -- +-- deleteRangeOnTextEditor :: TextEditorData -> Int -> Int -> Int -> Int -> IO () deleteRangeOnTextEditor (TextEditorData _ codeView _ _) startLineNo startColNo endLineNo endColNo = do buf <- textViewGetBuffer codeView @@ -761,9 +736,9 @@ endIter <- textBufferGetIterAtLineOffset buf endLineNo endColNo textBufferDelete buf startIter endIter --- | --- --- +-- | +-- +-- getSelectedText :: TextEditorData -> IO String getSelectedText (TextEditorData _ codeView _ _) = do buf <- textViewGetBuffer codeView @@ -773,9 +748,9 @@ textBufferGetText buf startIter endIter False False -> return "" --- | --- --- +-- | +-- +-- getCurrentVisibleLines :: TextEditorData -> IO (Int, Int) getCurrentVisibleLines (TextEditorData _ codeView _ _) = do (Rectangle _ startY _ h) <- textViewGetVisibleRect codeView @@ -789,9 +764,9 @@ return (startNo, endNo) --- | --- --- +-- | +-- +-- isLineVisible :: TextEditorData -> Int -> IO Bool isLineVisible editor lineNo = do (startNo, endNo) <- getCurrentVisibleLines editor diff --git a/app/Phoityne/IO/GUI/GTK/TraceTable.hs b/app/Phoityne/IO/GUI/GTK/TraceTable.hs --- a/app/Phoityne/IO/GUI/GTK/TraceTable.hs +++ b/app/Phoityne/IO/GUI/GTK/TraceTable.hs @@ -6,121 +6,112 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.IO.GUI.GTK.TraceTable ( - TraceData(..) +module Phoityne.IO.GUI.GTK.TraceTable ( + TraceData(..) , TraceDataListStore -, TraceTableDoubleClickedHandler -, createTraceDataListStore -, setupTraceTable -, updateTraceTable +, TraceTableDoubleClickedHandler +, createTraceDataListStore +, setupTraceTable +, updateTraceTable ) where - + -- モジュール -import Phoityne.IO.GUI.GTK.Constant -import Phoityne.IO.GUI.GTK.Utility - --- システム -import Graphics.UI.Gtk + +-- システム +import Graphics.UI.Gtk import Control.Monad.IO.Class -- | --- --- -data TraceData = TraceData { - traceIdTraceData :: String - , functionTraceData :: String - , filePathTraceData :: String - } deriving (Show, Read, Eq, Ord) - +-- +-- +data TraceData = TraceData { + traceIdTraceData :: String + , functionTraceData :: String + , filePathTraceData :: String + } deriving (Show, Read, Eq, Ord) + -- | --- --- -type TraceDataListStore = ListStore TraceData +-- +-- +type TraceDataListStore = ListStore TraceData --- | --- --- -type TraceTableDoubleClickedHandler = TraceData -> IO () - +-- | +-- +-- +type TraceTableDoubleClickedHandler = TraceData -> IO () --- | --- --- -createTraceDataListStore :: IO TraceDataListStore -createTraceDataListStore = listStoreNew ([] :: [TraceData]) - --- | --- --- -setupTraceTable :: Builder -> TraceDataListStore -> TraceTableDoubleClickedHandler -> IO () -setupTraceTable builder store evh = do - - treeView <- builderGetObject builder castToTreeView "TraceTreeView" - - col <- builderGetObject builder castToTreeViewColumn ("TraceCol1" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := traceIdTraceData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("TraceCol2" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := functionTraceData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - col <- builderGetObject builder castToTreeViewColumn ("TraceCol3" :: String) - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer store $ \cell -> - [ cellText := filePathTraceData cell - , cellTextFont := _FONT_DESC - , cellTextSize := 9 - ] - _ <- treeViewSetModel treeView store - - _ <- on treeView buttonPressEvent $ traceTableDoubleClickedHandler treeView store evh - - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle - - setFont treeView - widgetShowAll treeView +-- | +-- +-- +createTraceDataListStore :: IO TraceDataListStore +createTraceDataListStore = listStoreNew ([] :: [TraceData]) - --- | --- --- -traceTableDoubleClickedHandler :: TreeView -> ListStore TraceData -> TraceTableDoubleClickedHandler -> EventM EButton Bool -traceTableDoubleClickedHandler self listStore evh = eventClick >>= \case - DoubleClick -> liftIO $ do - sel <- treeViewGetSelection self - treeSelectionGetSelected sel >>= \case - Nothing -> return False - Just iter -> do - let idx = listStoreIterToIndex iter - bpDat <- listStoreGetValue listStore idx - evh bpDat - return False - + +-- | +-- +-- +setupTraceTable :: Builder -> TraceDataListStore -> TraceTableDoubleClickedHandler -> IO () +setupTraceTable builder store evh = do + + treeView <- builderGetObject builder castToTreeView "TraceTreeView" + + col <- builderGetObject builder castToTreeViewColumn ("TraceCol1" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := traceIdTraceData cell + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("TraceCol2" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := functionTraceData cell + ] + _ <- treeViewSetModel treeView store + + col <- builderGetObject builder castToTreeViewColumn ("TraceCol3" :: String) + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer store $ \cell -> + [ cellText := filePathTraceData cell + ] + _ <- treeViewSetModel treeView store + + _ <- on treeView buttonPressEvent $ traceTableDoubleClickedHandler treeView store evh + + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + widgetShowAll treeView + + +-- | +-- +-- +traceTableDoubleClickedHandler :: TreeView -> ListStore TraceData -> TraceTableDoubleClickedHandler -> EventM EButton Bool +traceTableDoubleClickedHandler self listStore evh = eventClick >>= \case + DoubleClick -> liftIO $ do + sel <- treeViewGetSelection self + treeSelectionGetSelected sel >>= \case + Nothing -> return False + Just iter -> do + let idx = listStoreIterToIndex iter + bpDat <- listStoreGetValue listStore idx + evh bpDat + return False + _ -> return False - + -- | --- --- -updateTraceTable :: ListStore TraceData -> [TraceData] -> IO () -updateTraceTable store dats= do - listStoreClear store - mapM_ (listStoreAppend store) dats - +-- +-- +updateTraceTable :: ListStore TraceData -> [TraceData] -> IO () +updateTraceTable store dats= do + listStoreClear store + mapM_ (listStoreAppend store) dats + diff --git a/app/Phoityne/IO/GUI/GTK/Utility.hs b/app/Phoityne/IO/GUI/GTK/Utility.hs --- a/app/Phoityne/IO/GUI/GTK/Utility.hs +++ b/app/Phoityne/IO/GUI/GTK/Utility.hs @@ -6,102 +6,88 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} -module Phoityne.IO.GUI.GTK.Utility +module Phoityne.IO.GUI.GTK.Utility where -- モジュール -import Phoityne.IO.GUI.GTK.Constant --- システム -import Graphics.UI.Gtk +-- システム +import Graphics.UI.Gtk import qualified Control.Exception as E -import qualified Data.List as L -import qualified Data.Text as T +import qualified Data.List as L +import qualified Data.Text as T -- | -- --- -isContainer :: GObjectClass cls => cls -> IO Bool -isContainer w = flip E.catches handlers $ do - _ <- containerGetChildren $ castToContainer w - return True +-- +isContainer :: GObjectClass cls => cls -> IO Bool +isContainer w = flip E.catches handlers $ do + _ <- containerGetChildren $ castToContainer w + return True where handlers = [ E.Handler someExcept ] - someExcept (_ :: E.SomeException) = return False - + someExcept (_ :: E.SomeException) = return False + + -- | --- --- -setFont :: GObjectClass cls => cls -> IO () -setFont w = do - fontDesc <- fontDescriptionNew - fontDescriptionSetFamily fontDesc _FONT_DESC - widgetOverrideFont (castToWidget w) (Just fontDesc) - isContainer w >>= \case - True -> do - childs <- containerGetChildren $ castToContainer w - mapM_ setFont childs - False -> return () - +-- +-- +add2ListStore :: Eq a => ListStore a -> a -> IO () +add2ListStore store item = do + listDat <- listStoreToList store + if True == L.elem item listDat then return () + else listStoreAppend store item >> return () + -- | --- --- -add2ListStore :: Eq a => ListStore a -> a -> IO () -add2ListStore store item = do - listDat <- listStoreToList store - if True == L.elem item listDat then return () - else listStoreAppend store item >> return () - +-- +-- +deleteFromListStore :: Eq a => ListStore a -> a -> IO () +deleteFromListStore store item = + listStoreToList store >>= deleteFromList + where + deleteFromList listDat + | True == L.elem item listDat = treeModelForeach (castToTreeModel store) deleteData + | otherwise = return () + + deleteData iter = do + let idx = listStoreIterToIndex iter + val <- listStoreGetValue store idx + if val == item then listStoreRemove store idx >> return False + else return False + -- | --- --- -deleteFromListStore :: Eq a => ListStore a -> a -> IO () -deleteFromListStore store item = - listStoreToList store >>= deleteFromList - where - deleteFromList listDat - | True == L.elem item listDat = treeModelForeach (castToTreeModel store) deleteData - | otherwise = return () - - deleteData iter = do - let idx = listStoreIterToIndex iter - val <- listStoreGetValue store idx - if val == item then listStoreRemove store idx >> return False - else return False - --- | --- --- -forceEvent :: IO () -forceEvent = eventsPending >>= go - where - go c | 0 < c = mainIterationDo True >> forceEvent - | otherwise = return () - +-- +-- +forceEvent :: IO () +forceEvent = eventsPending >>= go + where + go c | 0 < c = mainIterationDo True >> forceEvent + | otherwise = return () + -- | --- --- -imageNewFromIcon :: T.Text -> Int -> IO (Maybe Image) -imageNewFromIcon iconName size = do - iconTheme <- iconThemeGetDefault - iconThemeLoadIcon iconTheme iconName size IconLookupUseBuiltin >>= \case - Just p -> imageNewFromPixbuf p >>= return . Just +-- +-- +imageNewFromIcon :: T.Text -> Int -> IO (Maybe Image) +imageNewFromIcon iconName size = do + iconTheme <- iconThemeGetDefault + iconThemeLoadIcon iconTheme iconName size IconLookupUseBuiltin >>= \case + Just p -> imageNewFromPixbuf p >>= return . Just Nothing -> return Nothing - + -- | --- --- -deleteTagAtTextIter :: TextIter -> IO () -deleteTagAtTextIter iter = do - textBuf <- textIterGetBuffer iter - tagTable <- textBufferGetTagTable textBuf - tags <- textIterGetTags iter - mapM_ (textTagTableRemove tagTable) tags +-- +-- +deleteTagAtTextIter :: TextIter -> IO () +deleteTagAtTextIter iter = do + textBuf <- textIterGetBuffer iter + tagTable <- textBufferGetTagTable textBuf + tags <- textIterGetTags iter + mapM_ (textTagTableRemove tagTable) tags -- | --- --- +-- +-- forwardTextIter :: TextIter -> Int -> IO (Maybe TextIter) forwardTextIter iter 0 = return $ Just iter forwardTextIter iter count = textIterForwardChar iter >>= \case diff --git a/app/Phoityne/IO/Main.hs b/app/Phoityne/IO/Main.hs --- a/app/Phoityne/IO/Main.hs +++ b/app/Phoityne/IO/Main.hs @@ -87,6 +87,8 @@ , "[PHOITYNE]" , "target = ." , "ghci_auto_start = True" + , "system_font_name = MS Gothic" + , "system_font_size = 9" ] -- | diff --git a/app/Phoityne/IO/Utility.hs b/app/Phoityne/IO/Utility.hs --- a/app/Phoityne/IO/Utility.hs +++ b/app/Phoityne/IO/Utility.hs @@ -2,47 +2,47 @@ module Phoityne.IO.Utility where --- システム -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LBS -import GHC.IO.Encoding +-- システム +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LBS +import GHC.IO.Encoding import Distribution.System -import Control.Monad.Trans.Resource -import qualified Data.Conduit.Binary as C -import qualified Data.Conduit as C -import qualified Data.Conduit.List as C - +import Control.Monad.Trans.Resource +import qualified Data.Conduit.Binary as C +import qualified Data.Conduit as C +import qualified Data.Conduit.List as C + -- | --- --- -getReadHandleEncoding :: IO TextEncoding -getReadHandleEncoding = if - | Windows == buildOS -> mkTextEncoding "CP932" - | otherwise -> return utf8 - +-- +-- +getReadHandleEncoding :: IO TextEncoding +getReadHandleEncoding = if + | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" + | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" + -- | --- --- -loadFile :: FilePath -> IO B.ByteString -loadFile path = do - bs <- runResourceT - $ C.sourceFile path - C.$$ C.consume - return $ B.concat bs - +-- +-- +loadFile :: FilePath -> IO B.ByteString +loadFile path = do + bs <- runResourceT + $ C.sourceFile path + C.$$ C.consume + return $ B.concat bs + -- | --- --- -saveFile :: FilePath -> B.ByteString -> IO () -saveFile path cont = saveFileLBS path $ LBS.fromStrict cont - +-- +-- +saveFile :: FilePath -> B.ByteString -> IO () +saveFile path cont = saveFileLBS path $ LBS.fromStrict cont + -- | --- --- -saveFileLBS :: FilePath -> LBS.ByteString -> IO () -saveFileLBS path cont = runResourceT - $ C.sourceLbs cont - C.$$ C.sinkFile path - - - +-- +-- +saveFileLBS :: FilePath -> LBS.ByteString -> IO () +saveFileLBS path cont = runResourceT + $ C.sourceLbs cont + C.$$ C.sinkFile path + + + diff --git a/app/Phoityne/Type.hs b/app/Phoityne/Type.hs deleted file mode 100644 --- a/app/Phoityne/Type.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Phoityne.Type where - - - - diff --git a/app/Phoityne/Utility.hs b/app/Phoityne/Utility.hs --- a/app/Phoityne/Utility.hs +++ b/app/Phoityne/Utility.hs @@ -11,9 +11,9 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.ConfigFile as CFG -import qualified Data.Tree as TR - +import qualified Data.Tree as TR + -- | -- UTF8文字列をByteStringへの変換 -- @@ -53,16 +53,16 @@ -- | --- --- -addChildTree :: TR.Tree a -> TR.Tree a -> TR.Tree a -addChildTree parent child = parent { TR.subForest = child : curForest} +-- +-- +addChildTree :: TR.Tree a -> TR.Tree a -> TR.Tree a +addChildTree parent child = parent { TR.subForest = child : curForest} where curForest = TR.subForest parent -- | --- --- +-- +-- pushWithLimit :: (Eq a, Ord a) => [a] -> a -> Int -> [a] pushWithLimit [] item _ = [item] pushWithLimit buf item maxSize = if length buf > maxSize then item : L.init buf else item : buf diff --git a/conf/Phoityne.glade b/conf/Phoityne.glade --- a/conf/Phoityne.glade +++ b/conf/Phoityne.glade @@ -6,57 +6,36 @@ True False Name - - - True False Type - - - True False Value - - - True False Module - - - True False FilePath - - - True False LineNo - - - True False Condition - - - @@ -117,9 +96,6 @@ False start Input replacement - - - False @@ -137,9 +113,6 @@ True False Search - - - 0 @@ -151,9 +124,6 @@ True False Replace - - - 0 @@ -257,9 +227,6 @@ False start Input keyword - - - False @@ -291,68 +258,44 @@ True False FilePath - - - True False Line No L - - - True False Start Col No SC - - - True False End Col No EC - - - True False Line - - - True False TraceId - - - True False Function - - - True False FilePath - - - False @@ -477,7 +420,7 @@ True False - Build(F7) + Build(F7, Rebuild Shift+F7) True BuildLabel True @@ -547,7 +490,7 @@ True False - Exit Debug(Shift+F5) + Stop Debug(Shift+F5) True DebugStopLabel True @@ -752,10 +695,7 @@ True False - Welcome!! - - - + True False @@ -819,9 +759,6 @@ True False Console - - - False @@ -942,9 +879,6 @@ True False BreakPoint - - - False @@ -998,9 +932,6 @@ True False Bindings - - - 1 @@ -1052,9 +983,6 @@ True False Trace - - - 2 @@ -1159,9 +1087,6 @@ True False Search - - - 3 @@ -1266,9 +1191,6 @@ False start Input folder name. - - - False diff --git a/phoityne.cabal b/phoityne.cabal --- a/phoityne.cabal +++ b/phoityne.cabal @@ -1,7 +1,7 @@ name: phoityne -version: 0.0.3.0 +version: 0.0.4.0 synopsis: ghci debug viewer with simple editor. -description: Phoityne is a ghci debug viewer with simple editor. +description: Phoityne is a ghci debug viewer with simple editor. license: BSD3 license-file: LICENSE author: phoityne_hs @@ -9,32 +9,31 @@ category: Development build-type: Simple cabal-version: >=1.10 -extra-source-files: README.md - , Changelog.md -data-files: conf/*.ico - , conf/*.glade +extra-source-files: README.md + , Changelog.md +data-files: conf/*.ico + , conf/*.glade , conf/*.png executable phoityne ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing hs-source-dirs: app main-is: Main.hs - other-modules: Paths_phoityne - , Phoityne.Argument - , Phoityne.Constant - , Phoityne.Type - , Phoityne.Utility - , Phoityne.IO.Control - , Phoityne.IO.Main - , Phoityne.IO.Utility - , Phoityne.IO.CUI.GHCiControl - , Phoityne.IO.GUI.Control - , Phoityne.IO.GUI.GTK.BreakPointTable - , Phoityne.IO.GUI.GTK.BindingTable - , Phoityne.IO.GUI.GTK.Interface - , Phoityne.IO.GUI.GTK.TextEditor - , Phoityne.IO.GUI.GTK.TraceTable - , Phoityne.IO.GUI.GTK.Constant + other-modules: Paths_phoityne + , Phoityne.Argument + , Phoityne.Constant + , Phoityne.Utility + , Phoityne.IO.Control + , Phoityne.IO.Main + , Phoityne.IO.Utility + , Phoityne.IO.CUI.GHCiControl + , Phoityne.IO.GUI.Control + , Phoityne.IO.GUI.GTK.BreakPointTable + , Phoityne.IO.GUI.GTK.BindingTable + , Phoityne.IO.GUI.GTK.Interface + , Phoityne.IO.GUI.GTK.TextEditor + , Phoityne.IO.GUI.GTK.TraceTable + , Phoityne.IO.GUI.GTK.Constant , Phoityne.IO.GUI.GTK.Utility , Phoityne.IO.GUI.GTK.FolderTree , Phoityne.IO.GUI.GTK.SearchResultTable @@ -46,20 +45,28 @@ , text , bytestring , MissingH - , safe + , safe , HStringTemplate - , gtk3 - , transformers - , containers - , mtl - , filepath - , directory - , conduit - , conduit-extra - , resourcet - , process - , parsec - , Cabal + , gtk3 + , transformers + , containers + , mtl + , filepath + , directory + , conduit + , conduit-extra + , resourcet + , process + , parsec + , Cabal default-language: Haskell2010 +test-suite phoityne-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hspec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ + +main :: IO () +main = putStrLn "Test suite not yet implemented"