diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2015
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Author name here nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+-- モジュール
+import qualified Phoityne.IO.Main as M
+
+-- システム
+import System.Exit
+
+
+-- |
+-- メイン
+--
+main :: IO ()
+main = do
+ M.run >>= \case
+ 0 -> exitSuccess
+ c -> exitWith . ExitFailure $ c
+
diff --git a/app/Phoityne/Argument.hs b/app/Phoityne/Argument.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/Argument.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-cse #-}
+
+module Phoityne.Argument (
+ HelpExitException(..)
+, ArgData(..)
+, config
+) where
+
+-- システム
+import System.Console.CmdArgs
+import qualified Control.Exception as E
+
+-- |
+-- ヘルプ表示時の例外
+--
+data HelpExitException = HelpExitException
+ deriving (Show, Typeable)
+
+instance E.Exception HelpExitException
+
+-- |
+-- コマンドライン引数データ設定
+-- モードを使用する場合のサンプル
+--
+data ArgData = ModeA
+ {
+ file :: String
+ , method :: Method
+ }
+ | ModeB
+ {
+ file :: String
+ , value :: Int
+ } deriving (Data, Typeable, Show, Read, Eq)
+
+-- |
+-- アノテーション設定
+--
+config :: ArgData
+config = modes [confA, confB]
+ &= summary sumMsg
+ &= program "prj-tpl"
+
+ where
+ confA = ModeA {
+ file = def
+ &= name "f"
+ &= name "file"
+ &= explicit
+ &= typFile
+ &= help "ini file"
+ , method = enum
+ [
+ Get
+ &= name "get"
+ &= explicit
+ &= help "method type Get"
+ , Post
+ &= name "post"
+ &= explicit
+ &= help " | type Post"
+ , Put
+ &= name "put"
+ &= explicit
+ &= help " | type Put"
+ , Delete
+ &= name "delete"
+ &= explicit
+ &= help " | type Delete"
+ ]
+ } &= name "ModeA"
+ &= details mdAMsg
+ &= auto
+ confB = ModeB {
+ file = def
+ &= name "f"
+ &= name "file"
+ &= explicit
+ &= typFile
+ &= help "ini file"
+ , value = def
+ &= name "value"
+ &= explicit
+ &= help "integer value"
+ } &= name "ModeB"
+ &= details mdBMsg
+
+ sumMsg = unlines [
+ ""
+ , " ☆ サマリ説明 ☆"
+ , ""
+ , " ここに簡単な説明を記載する。"
+ , ""
+ ]
+
+ mdAMsg = [
+ ""
+ , " ★ 詳細説明 ★"
+ , ""
+ , " ここにModeAの詳細な説明を記載する。"
+ , ""
+ ]
+
+ mdBMsg = [
+ ""
+ , " ★ 詳細説明 ★"
+ , ""
+ , " ここにModeBの詳細な説明を記載する。"
+ , ""
+ ]
+
+-- |
+-- enum値引数
+--
+data Method = Get | Post | Put | Delete
+ deriving (Data, Typeable, Show, Read, Eq)
+
+
diff --git a/app/Phoityne/Constant.hs b/app/Phoityne/Constant.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/Constant.hs
@@ -0,0 +1,76 @@
+
+module Phoityne.Constant where
+
+-- |
+--
+--
+_INI_SEC_LOG :: String
+_INI_SEC_LOG = "LOG"
+
+_INI_LOG_FILE :: String
+_INI_LOG_FILE = "file"
+
+_INI_LOG_LEVEL :: String
+_INI_LOG_LEVEL = "level"
+
+_INI_SEC_PHOITYNE :: String
+_INI_SEC_PHOITYNE = "PHOITYNE"
+
+_INI_SEC_PHOITYNE_TARGET_DIR :: String
+_INI_SEC_PHOITYNE_TARGET_DIR = "target"
+
+
+_LOG_NAME :: String
+_LOG_NAME = "phoityne"
+
+_LOG_FORMAT :: String
+_LOG_FORMAT = "$time [$tid] $prio $loggername - $msg"
+
+_LOG_FORMAT_DATE :: String
+_LOG_FORMAT_DATE = "%Y-%m-%d %H:%M:%S"
+
+-- |
+--
+--
+type ModuleName = 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"
+
+_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_BLACK :: String
+_STARTUP_MODULE_COLOR_BLACK = "black"
+
+
+-- |
+--
+--
+_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
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/CUI/GHCiControl.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.CUI.GHCiControl where
+
+-- モジュール
+import Phoityne.Constant
+import Phoityne.IO.Utility
+
+-- システム
+import System.Process
+import System.IO
+import System.Exit
+import System.Log.Logger
+
+
+-- |
+--
+--
+data ExternalCommandData = ExternalCommandData
+ {
+ inExternalCommandData :: Maybe Handle
+ , outExternalCommandData :: Maybe Handle
+ , errExternalCommandData :: Maybe Handle
+ , procExternalCommandData :: Maybe ProcessHandle
+ }
+
+
+-- |
+--
+--
+defaultExternalCommandData :: ExternalCommandData
+defaultExternalCommandData = ExternalCommandData Nothing Nothing Nothing Nothing
+
+
+-- |
+--
+--
+run :: String -> [String] -> Maybe FilePath -> IO ExternalCommandData
+run cmd opts curDir = do
+
+ (stdInReadHandle, stdInWriteHandle) <- createPipe
+ (outReadHandle, outWriteHandle) <- createPipe
+
+ hSetBuffering stdInReadHandle NoBuffering
+ hSetBuffering stdInWriteHandle NoBuffering
+
+ hSetBuffering outReadHandle NoBuffering
+ hSetBuffering outWriteHandle NoBuffering
+
+ osEnc <- getReadHandleEncoding
+
+ hSetEncoding stdInReadHandle osEnc
+ hSetEncoding stdInWriteHandle utf8
+
+ hSetEncoding outReadHandle osEnc
+ hSetEncoding outWriteHandle utf8
+
+ ghciProc <- runProcess cmd opts curDir Nothing (Just stdInReadHandle) (Just outWriteHandle) (Just outWriteHandle)
+
+ return $ ExternalCommandData (Just stdInWriteHandle) (Just outReadHandle) (Just outReadHandle) (Just ghciProc)
+
+
+-- |
+--
+--
+waitExit :: ExternalCommandData -> IO ExitCode
+waitExit (ExternalCommandData _ _ _ (Just ghciProc)) = do
+ waitForProcess ghciProc
+waitExit _ = do
+ criticalM _LOG_NAME "waitExit"
+ return $ ExitFailure 2
+
+
+-- |
+--
+--
+writeLine :: ExternalCommandData -> String -> IO ()
+writeLine (ExternalCommandData (Just ghciIn) _ _ _) cmd = hPutStrLn ghciIn cmd
+writeLine _ _ = criticalM _LOG_NAME "writeLine"
+
+
+-- |
+--
+--
+readWhile :: ExternalCommandData -> (String -> Bool) -> IO String
+readWhile (ExternalCommandData _ (Just ghciOut) _ _) proc = go []
+ where
+ go acc = hIsEOF ghciOut >>= \case
+ True -> return acc
+ False -> do
+ c <- hGetChar ghciOut
+ let acc' = acc ++ [c]
+ if proc acc' then go acc'
+ else return acc'
+
+readWhile _ _ = criticalM _LOG_NAME "readWhile" >> return ""
+
+
+-- |
+--
+--
+readLineWhileIO :: ExternalCommandData -> ([String] -> IO Bool) -> IO [String]
+readLineWhileIO (ExternalCommandData _ (Just ghciOut) _ _) proc = go []
+ where
+ go acc = hIsEOF ghciOut >>= \case
+ True -> return acc
+ False -> do
+ l <- hGetLine ghciOut
+ let acc' = acc ++ [l]
+ proc acc' >>= \case
+ True -> go acc'
+ False -> return acc'
+
+readLineWhileIO _ _ = criticalM _LOG_NAME "readLineWhileIO" >> return []
+
diff --git a/app/Phoityne/IO/Control.hs b/app/Phoityne/IO/Control.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/Control.hs
@@ -0,0 +1,179 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.Control where
+
+-- モジュール
+import Phoityne.Constant
+import qualified Phoityne.Argument as A
+import qualified Phoityne.IO.GUI.Control as GUI
+import qualified Phoityne.IO.CUI.GHCiControl as GHCI
+
+-- システム
+import System.Directory
+import System.Info
+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
+
+-- |
+-- ロジックメイン
+--
+run :: A.ArgData -- コマンドライン引数
+ -> C.ConfigParser -- INI設定
+ -> IO Int -- exit code
+run _ ini = do
+
+ let cwdSet = forceEither $ C.get ini _INI_SEC_PHOITYNE _INI_SEC_PHOITYNE_TARGET_DIR
+ 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
+
+ mvarCUI <- newMVar GHCI.defaultExternalCommandData
+
+ let cmdData = createCmdData mvarCUI cwd
+
+ GUI.createMainWindow cmdData [cwd]
+
+ 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.forceDebugCommandData = \arg -> execCmd mvarCUI $ ":force " ++ arg
+ , 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.readWhileDebugCommandData = readWhile mvarCUI
+ }
+
+
+-- |
+--
+--
+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
+
+
+-- |
+--
+--
+buildStart :: MVar GHCI.ExternalCommandData -> FilePath -> IO ()
+buildStart mvarCUI cwd = do
+ exeData <- GHCI.run "stack" ["build"] $ 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
+
+
+-- |
+--
+--
+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
+
+
+-- |
+--
+--
+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
+
+
+-- |
+--
+--
+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
+
+
+-- |
+--
+--
+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
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/Control.hs
@@ -0,0 +1,2211 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.Control (
+ createMainWindow
+, DebugCommandData(..)
+) where
+
+-- モジュール
+import Phoityne.Constant
+import Phoityne.Utility
+import Phoityne.IO.Utility
+import qualified Phoityne.IO.GUI.GTK.Interface as IF
+
+-- システム
+import System.Exit
+import System.FilePath
+import System.Directory
+import System.Log.Logger
+import Control.Monad
+import Control.Concurrent
+import Data.Maybe
+import Data.String.Utils
+import Data.Char
+import Data.Functor.Identity
+import Text.Parsec
+import qualified Data.Map as Map
+import qualified Data.List as L
+import qualified Data.Tree as T
+import qualified Data.Text as TE
+import qualified Data.Text.Encoding as TE
+import qualified Text.StringTemplate as TPL
+
+
+-- |
+--
+--
+type NoteMap = Map.Map IF.NodeData IF.TextEditorData
+
+-- |
+--
+--
+data UndoRedoData =
+ DeleteRangeUndoRedoData {
+ filePathDeleteRangeUndoRedoData :: FilePath
+ , startLineNoDeleteRangeUndoRedoData :: Int
+ , startColNoDeleteRangeUndoRedoData :: Int
+ , endLineNoDeleteRangeUndoRedoData :: Int
+ , endColNoDeleteRangeUndoRedoData :: Int
+ , textDeleteRangeUndoRedoData :: String
+ } |
+ InsertTextUndoRedoData {
+ filePathInsertTextUndoRedoData :: FilePath
+ , startLineNoInsertTextUndoRedoData :: Int
+ , startColNoInsertTextUndoRedoData :: Int
+ , textInsertTextUndoRedoData :: String
+ }
+ deriving (Show, Read, Eq, Ord)
+
+-- |
+--
+--
+data MVarGUIData =
+ MVarGUIData {
+ widgetStoreMVarGUIData :: IF.WidgetStore
+ , breakPointListMVarGUIData :: IF.BreakPointListStore
+ , codeNoteMapMVarGUIData :: NoteMap
+ , folderTreeMVarGUIData :: IF.FolderTreeStore
+ , bindingListStoreMVarGUIData :: IF.BindingListStore
+ , traceListStoreMVarGUIData :: IF.TraceDataListStore
+ , searchResultListStoreMVarGUIData :: IF.SearchResultListStore
+ , traceIdMVarGUIData :: Int
+ , undoBufferMVarGUIData :: [UndoRedoData]
+ , redoBufferMVarGUIData :: [UndoRedoData]
+ , unDoReDoFlagMVarGUIData :: Bool
+ , buildMsgMVarGUIData :: [String]
+ , searchFilesMVarGUIData :: [FilePath]
+ , startupNodeDataMVarGUIData :: Maybe IF.NodeData
+ }
+
+-- |
+--
+--
+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
+ }
+
+-- |
+--
+--
+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
+ -> MVarGUIData
+defaultMVarGUIData widgets breaks folder bindings trace search =
+ 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
+ }
+
+-- |
+--
+--
+createMainWindow :: DebugCommandData -> [FilePath] -> IO ()
+createMainWindow cmdData paths = do
+
+ -- Storeの作成
+ builder <- IF.getBuilder
+ breakStore <- IF.createBreakPointListStore
+ bindingStore <- IF.createBindingListStore
+ traceStore <- IF.createTraceDataListStore
+ searchResultStore <- IF.createSearchResultListStore
+ treeStore <- loadFolderForest _PROJECT_ROOT_MODULE_NAME paths >>= IF.createTreeStore
+
+ -- GUI共有データの作成
+ mvarGUI <- newMVar $ defaultMVarGUIData builder breakStore treeStore bindingStore traceStore searchResultStore
+
+ -- イベントハンドラの登録
+ IF.setupMainWindow builder
+ (mainWindowCloseEventHanlder)
+ (mainWindowKeyPressEventHandler mvarGUI cmdData)
+
+ IF.setupToolButton builder
+ (toolBTdebugStartHandler mvarGUI cmdData)
+ (toolBTdebugStopHandler mvarGUI cmdData)
+ (toolBTstepOverHandler mvarGUI cmdData)
+ (toolBTstepInHandler mvarGUI cmdData)
+ (toolBTcontinueHandler mvarGUI cmdData)
+ (toolBTbuildHandler mvarGUI cmdData)
+ (toolBTdeleteHandler mvarGUI cmdData)
+ (toolBTsaveHandler mvarGUI cmdData)
+ (toolBTindentHandler mvarGUI)
+ (toolBTunIndentHandler mvarGUI)
+ (toolBTcommentHandler mvarGUI)
+ (toolBTunCommentHandler mvarGUI)
+
+ 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)
+
+ IF.setupBindingTable builder bindingStore
+ (bindingTableDoubleClickedHandler mvarGUI cmdData)
+
+ IF.setupTraceTable builder traceStore
+ (traceTableDoubleClickedHandler mvarGUI cmdData)
+
+ IF.setupSearchResultTable builder searchResultStore
+ (searchResultTableDoubleClickedHandler mvarGUI cmdData)
+
+ -- 開始
+ IF.start builder
+
+
+-- |=====================================================================
+-- MainWindowのイベントハンドラ
+--
+
+-- |
+--
+--
+mainWindowCloseEventHanlder :: IF.MainWindowCloseEventHandler
+mainWindowCloseEventHanlder = infoM _LOG_NAME "See you again."
+
+-- |
+--
+--
+mainWindowKeyPressEventHandler :: MVar MVarGUIData -> DebugCommandData -> IF.MainWindowKeyPressEventHandler
+mainWindowKeyPressEventHandler mvarGUI cmdDat "F5" isShift _ = do
+ guiData <- readMVar mvarGUI
+ let builder = widgetStoreMVarGUIData guiData
+
+ isStart <- IF.isDebugStart builder
+ withStart isStart isShift
+
+ return True
+
+ where
+ withStart True True = toolBTdebugStopHandler mvarGUI cmdDat
+ withStart True False = toolBTcontinueHandler mvarGUI cmdDat
+ withStart False False = toolBTdebugStartHandler mvarGUI cmdDat
+ withStart _ _ = return ()
+
+mainWindowKeyPressEventHandler mvarGUI cmdDat "F7" True _ = do
+ guiData <- readMVar mvarGUI
+ let builder = widgetStoreMVarGUIData guiData
+ isStart <- IF.isBuildStart builder
+
+ when (False == isStart) $ do
+ 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
+ isStart <- IF.isBuildStart builder
+
+ when (False == isStart) $ do
+ IF.clearConsole builder
+ toolBTbuildHandler mvarGUI cmdDat
+
+ return True
+
+mainWindowKeyPressEventHandler mvarGUI cmdDat "F10" _ _ = do
+ guiData <- takeMVar mvarGUI
+ let builder = widgetStoreMVarGUIData guiData
+ isStart <- IF.isDebugStart builder
+ putMVar mvarGUI guiData
+
+ if isStart then toolBTstepOverHandler mvarGUI cmdDat
+ else return ()
+
+ return True
+
+mainWindowKeyPressEventHandler mvarGUI cmdDat "F11" _ _ = do
+ guiData <- takeMVar mvarGUI
+ let builder = widgetStoreMVarGUIData guiData
+ isStart <- IF.isDebugStart builder
+ putMVar mvarGUI guiData
+
+ if isStart then toolBTstepInHandler mvarGUI cmdDat
+ else return ()
+
+ return True
+
+
+mainWindowKeyPressEventHandler mvarGUI cmdDat "s" _ True = do
+ saveAll mvarGUI cmdDat -- Ctr+s
+ 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
+ runGHCi >>= \case
+ False -> do
+ warningM _LOG_NAME "run ghci fail."
+ True -> loadHsFile >>= \case
+ False -> do
+ warningM _LOG_NAME "run ghci fail."
+ True -> setupDebug >> startDebug
+
+ where
+ runGHCi = do
+ guiData <- readMVar mvarGUI
+
+ let builder = widgetStoreMVarGUIData guiData
+ startCmd = startDebugCommandData cmdData
+ readLines = readLinesDebugCommandData cmdData
+ readWhile = readWhileDebugCommandData cmdData
+
+ IF.clearConsole builder
+ IF.putStrConsole builder $ "start stack ghci.\n"
+
+ startCmd
+
+ cont <- readLines (debugStartResultHandler builder)
+ if | null cont -> return False
+ | startswith "Ok," (last cont) -> do
+ res <- readWhile $ not . endswith "> "
+ IF.putStrConsole builder res
+ return True
+ | otherwise -> return False
+
+
+ loadHsFile = do
+ guiData <- readMVar mvarGUI
+ loadHsFileMay $ startupNodeDataMVarGUIData guiData
+
+ loadHsFileMay Nothing = return True
+ loadHsFileMay (Just nodeDat) = do
+ guiData <- readMVar mvarGUI
+ let builder = widgetStoreMVarGUIData guiData
+ loadFile = loadFileDebugCommandData cmdData
+ readLines = readLinesDebugCommandData cmdData
+ readWhile = readWhileDebugCommandData cmdData
+
+ cmdStr <- loadFile $ IF.getPathFromNodeData nodeDat
+ IF.putStrLnConsole builder cmdStr
+
+ cont <- readLines (debugStartResultHandler builder)
+
+ if | null cont -> return False
+ | startswith "Ok," (last cont) -> do
+ res <- readWhile $ not . endswith "> "
+ IF.putStrConsole builder res
+ return True
+ | otherwise -> return False
+
+ setupDebug = do
+
+ guiData <- readMVar mvarGUI
+
+ let builder = widgetStoreMVarGUIData guiData
+ breakStore = breakPointListMVarGUIData 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
+
+ IF.setupDebugButtonOn builder
+
+ breakList <- IF.getBreakPointList breakStore
+
+ mapM_ (addBreakPointOnCUI mvarGUI cmdData) breakList
+
+
+ startDebug = do
+
+ guiData <- readMVar mvarGUI
+
+ let builder = widgetStoreMVarGUIData guiData
+ getResult = readDebugCommandData cmdData
+ runDebug = runDebugCommandData cmdData
+
+ cmdStr <- runDebug True
+ IF.putStrLnConsole builder cmdStr
+
+ cmdStr <- getResult
+ IF.putStrConsole builder cmdStr
+ let breakPos = getStoppedTextRangeData cmdStr
+
+ continueWithHighlightTextRangeData mvarGUI cmdData breakPos
+
+ -- |
+ --
+ --
+ 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 cmdData = do
+
+ guiData <- takeMVar mvarGUI
+
+ let builder = widgetStoreMVarGUIData guiData
+ codeNoteMap = codeNoteMapMVarGUIData guiData
+ exitCmd = stopDebugCommandData cmdData
+ quitCmd = quitDebugCommandData cmdData
+ -- readLines = readLinesDebugCommandData cmdData
+ readWhile = readWhileDebugCommandData cmdData
+
+ putMVar mvarGUI guiData
+
+ 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.setupDebugButtonOff builder
+
+ mapM_ IF.offLightBreakPoint $ Map.elems codeNoteMap
+
+ return ()
+
+-- |
+-- 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.setupBuildButtonOff 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.setupBuildButtonOn builder
+
+ return ()
+
+ where
+
+ -- |
+ -- Event Handler
+ --
+ buildCallbackHandler :: MVar MVarGUIData -> Bool -> IO Bool
+ buildCallbackHandler mvarGUI doNotDelHandle = do
+
+ guiData <- takeMVar mvarGUI
+
+ let builder = widgetStoreMVarGUIData guiData
+ curMsg = buildMsgMVarGUIData guiData
+
+ putMVar mvarGUI guiData{ buildMsgMVarGUIData = [] }
+
+ mapM_ (IF.putStrConsole builder) curMsg
+
+ return doNotDelHandle
+
+ -- |
+ --
+ --
+ buildStartResultHandler :: MVar MVarGUIData -> [String] -> IO Bool
+ buildStartResultHandler _ [] = return False
+ buildStartResultHandler mvarGUI strs = do
+ appendBuildMsg mvarGUI $ last strs
+ return True
+
+ -- |
+ --
+ --
+ appendBuildMsg :: MVar MVarGUIData -> String -> IO ()
+ appendBuildMsg mvarGUI msg = do
+ guiData <- takeMVar mvarGUI
+ let curMsg = buildMsgMVarGUIData guiData
+ putMVar mvarGUI guiData{ buildMsgMVarGUIData = curMsg ++ [msg] }
+
+
+-- |
+-- Event Handler
+--
+toolBTdeleteHandler :: MVar MVarGUIData -> DebugCommandData -> IF.DeleteAllBreakBTClickedEventHandler
+toolBTdeleteHandler mvarGUI cmdData = do
+ guiData <- takeMVar mvarGUI
+ let bpList = breakPointListMVarGUIData guiData
+ noteMap = codeNoteMapMVarGUIData guiData
+
+ mapM_ IF.offLightBreakPoint $ Map.elems noteMap
+ putMVar mvarGUI guiData
+
+ IF.getBreakPointList bpList >>= mapM_ go
+
+ where
+ go (IF.BreakPointData _ path lineNo _ _) = do
+ let bpKey = (path, lineNo)
+ deleteBreakPointOnCUI mvarGUI cmdData bpKey
+ deleteBreakPointOnBPTable mvarGUI bpKey
+ deleteBreakPointTag mvarGUI bpKey
+
+-- |
+-- Event Handler
+--
+toolBTsaveHandler :: MVar MVarGUIData -> DebugCommandData -> IF.SaveBTClickedEventHandler
+toolBTsaveHandler = saveAll
+
+-- |
+-- 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
+
+
+-- |
+--
+--
+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 cmdDat "z" False True _ _ = do
+ guiData <- takeMVar mvarGUI
+
+ let buf = undoBufferMVarGUIData guiData
+ itemMay <- case buf of
+ [] -> putMVar mvarGUI guiData >> return Nothing
+ x:xs -> do
+ putMVar mvarGUI guiData{ undoBufferMVarGUIData = xs
+ , redoBufferMVarGUIData = x:redoBufferMVarGUIData guiData
+ , unDoReDoFlagMVarGUIData = True}
+ return $ Just x
+
+ unDo mvarGUI cmdDat itemMay
+
+ guiData <- takeMVar mvarGUI
+ putMVar mvarGUI guiData{unDoReDoFlagMVarGUIData = False}
+
+ return True
+
+ where
+ unDo :: MVar MVarGUIData -> DebugCommandData -> Maybe UndoRedoData -> IO ()
+ unDo _ _ Nothing = return ()
+ unDo mvarGUI cmdDat (Just (DeleteRangeUndoRedoData path startLineNo startColNo _ _ str)) = do
+ editorMay <- findTextEditorByPath mvarGUI path
+
+ activateWithEditor mvarGUI cmdDat editorMay path startLineNo
+
+ findTextEditorByPath mvarGUI path >>= \case
+ Nothing -> errorM _LOG_NAME $ "invalie note."
+ Just editor -> do
+ IF.insertText2TextEditor editor startLineNo startColNo str
+ IF.setCursorOnTextEditor editor startLineNo startColNo
+
+ unDo mvarGUI cmdDat (Just (InsertTextUndoRedoData path startLineNo startColNo str)) = do
+ editorMay <- findTextEditorByPath mvarGUI path
+
+ activateWithEditor mvarGUI cmdDat editorMay path startLineNo
+
+ findTextEditorByPath mvarGUI path >>= \case
+ Nothing -> errorM _LOG_NAME $ "invalie note."
+ Just editor -> do
+ (endLineNo, endColNo) <- IF.searchEndIter editor startLineNo startColNo str
+ IF.deleteRangeOnTextEditor editor startLineNo startColNo endLineNo endColNo
+ IF.setCursorOnTextEditor editor startLineNo startColNo
+
+codeTextKeyPressEventHandler mvarGUI cmdDat "y" False True _ _ = do
+ guiData <- takeMVar mvarGUI
+
+ let buf = redoBufferMVarGUIData guiData
+
+ itemMay <- case buf of
+ [] -> putMVar mvarGUI guiData >> return Nothing
+ x:xs -> do
+ putMVar mvarGUI guiData{ redoBufferMVarGUIData = xs
+ , unDoReDoFlagMVarGUIData = True}
+ return $ Just x
+
+ reDo mvarGUI cmdDat itemMay
+
+ guiData <- takeMVar mvarGUI
+ putMVar mvarGUI guiData{unDoReDoFlagMVarGUIData = False}
+
+ return True
+
+ where
+ reDo :: MVar MVarGUIData -> DebugCommandData -> Maybe UndoRedoData -> IO ()
+ reDo _ _ Nothing = return ()
+ reDo mvarGUI cmdDat (Just (DeleteRangeUndoRedoData path startLineNo startColNo _ _ str)) = do
+ editorMay <- findTextEditorByPath mvarGUI path
+
+ activateWithEditor mvarGUI cmdDat editorMay path startLineNo
+
+ findTextEditorByPath mvarGUI path >>= \case
+ Nothing -> errorM _LOG_NAME $ "[reDo]invalie note."
+ Just editor -> do
+ (endLineNo, endColNo) <- IF.searchEndIter editor startLineNo startColNo str
+ IF.deleteRangeOnTextEditor editor startLineNo startColNo endLineNo endColNo
+ IF.setCursorOnTextEditor editor startLineNo startColNo
+
+ return ()
+
+ reDo mvarGUI cmdDat (Just (InsertTextUndoRedoData path startLineNo startColNo str)) = do
+ editorMay <- findTextEditorByPath mvarGUI path
+
+ activateWithEditor mvarGUI cmdDat editorMay path startLineNo
+
+ findTextEditorByPath mvarGUI path >>= \case
+ Nothing -> errorM _LOG_NAME $ "[reDo] invalie note."
+ Just editor -> do
+ IF.insertText2TextEditor editor startLineNo startColNo str
+ (endLineNo, endColNo) <- IF.searchEndIter editor startLineNo startColNo str
+ IF.setCursorOnTextEditor editor endLineNo endColNo
+
+ return ()
+
+
+codeTextKeyPressEventHandler _ _ _ _ _ _ _ = return False
+
+
+-- |
+-- イベントハンドラ
+--
+codeBufferChangedEventHandler :: MVar MVarGUIData -> IO ()
+codeBufferChangedEventHandler _ = return ()
+
+
+
+-- |
+-- イベントハンドラ
+--
+codeBufferDeleteRangeEventHandler :: MVar MVarGUIData -> (Int, Int) -> (Int, Int) -> String -> IO ()
+codeBufferDeleteRangeEventHandler mvarGUI (siLineNo, siColNo) (eiLineNo, eiColNo) str = findCurrentTextEditor mvarGUI >>= \case
+ Nothing -> errorM _LOG_NAME "[codeBufferDeleteRangeEventHandler] invalid text editor."
+ Just a -> withEditor a
+ where
+ withEditor (nodeDat, _) = do
+ guiData <- takeMVar mvarGUI
+ let unDoBuf = undoBufferMVarGUIData guiData
+ reDoBuf = redoBufferMVarGUIData guiData
+ doing = unDoReDoFlagMVarGUIData guiData
+
+ let delDat = DeleteRangeUndoRedoData {
+ filePathDeleteRangeUndoRedoData = IF.getPathFromNodeData nodeDat
+ , startLineNoDeleteRangeUndoRedoData = siLineNo
+ , startColNoDeleteRangeUndoRedoData = siColNo
+ , endLineNoDeleteRangeUndoRedoData = eiLineNo
+ , endColNoDeleteRangeUndoRedoData = eiColNo
+ , textDeleteRangeUndoRedoData = str
+ }
+
+
+ let newUndoBuf = if doing then unDoBuf
+ else pushWithLimit unDoBuf delDat _UNDO_BUFFER_MAX_SIZE
+ let newRedoBuf = if doing then reDoBuf else []
+
+ putMVar mvarGUI guiData{ undoBufferMVarGUIData = newUndoBuf
+ , redoBufferMVarGUIData = newRedoBuf}
+
+
+-- |
+-- イベントハンドラ
+--
+codeBufferInsertTextEventHandler :: MVar MVarGUIData -> (Int, Int) -> String -> IO ()
+codeBufferInsertTextEventHandler mvarGUI (siLineNo, siColNo) str = findCurrentTextEditor mvarGUI >>= \case
+ Nothing -> errorM _LOG_NAME "[codeBufferInsertTextEventHandler] invalid text editor."
+ Just a -> withEditor a
+ where
+ withEditor (nodeDat, _) = do
+ guiData <- takeMVar mvarGUI
+ let unDoBuf = undoBufferMVarGUIData guiData
+ reDoBuf = redoBufferMVarGUIData guiData
+ doing = unDoReDoFlagMVarGUIData guiData
+
+ let insertDat = InsertTextUndoRedoData {
+ filePathInsertTextUndoRedoData = IF.getPathFromNodeData nodeDat
+ , startLineNoInsertTextUndoRedoData = siLineNo
+ , startColNoInsertTextUndoRedoData = siColNo
+ , textInsertTextUndoRedoData = str
+ }
+
+ let newUndoBuf = if doing then unDoBuf
+ else pushWithLimit unDoBuf insertDat _UNDO_BUFFER_MAX_SIZE
+ let newRedoBuf = if doing then reDoBuf else []
+
+ putMVar mvarGUI guiData{ undoBufferMVarGUIData = newUndoBuf
+ , redoBufferMVarGUIData = newRedoBuf}
+
+
+
+-- |=====================================================================
+-- Utility
+-- パーサ
+
+-- |
+-- コンソールに表示される文字列において、コードハイライトが可能な位置を
+-- 抽出するパーサ
+--
+getActivatePosFromLine :: String -> Maybe HighlightTextRangeData
+getActivatePosFromLine res = go $ split " " res
+ where
+ go [] = Nothing
+ go (x:xs) = case parse parseHighlightTextRange "getActivatePosFromLine" x of
+ Left _ -> go xs
+ Right bp -> Just bp
+
+-- |
+--
+--
+getHighlightTextRangeData :: String -> Either ParseError HighlightTextRangeData
+getHighlightTextRangeData = parse parseHighlightTextRange "getHighlightTextRangeData"
+
+
+-- |
+--
+--
+getStoppedTextRangeData :: String -> Either ParseError HighlightTextRangeData
+getStoppedTextRangeData = parse parser "getStoppedTextRangeData"
+ where
+ parser = do
+ _ <- manyTill anyChar (string "Stopped at ")
+ parseHighlightTextRange
+
+-- |
+-- 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
+--
+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 <- manyTill digit (char ':')
+ 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 mvarGUI 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 ()
+saveAll mvarGUI _ = do
+ guiData <- readMVar mvarGUI
+ let noteMap = codeNoteMapMVarGUIData guiData
+
+ mapM_ go $ Map.toList noteMap
+
+ where
+ go (nodeDat, editor) = do
+ isModified <- IF.isTextEditorModified editor
+ when isModified $ do
+ content <- IF.getCodeViewContent editor
+ saveFile (IF.getPathFromNodeData nodeDat) content
+ IF.setTextEditorModified editor False
+
+
+-- |
+-- すべての開いているテキストエディッタのコンテンツを再読み込みする。
+--
+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
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/BindingTable.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.BindingTable (
+ BindingListStore
+, BindingData(..)
+, BindingTableDoubleClickedHandler
+, setupBindingTable
+, createBindingListStore
+, updateBindingTable
+) where
+
+-- モジュール
+import Phoityne.IO.GUI.GTK.Constant
+import Phoityne.IO.GUI.GTK.Utility
+
+-- システム
+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)
+
+
+-- |
+--
+--
+updateBindingTable :: ListStore BindingData -> [BindingData] -> IO ()
+updateBindingTable store dats= do
+ listStoreClear store
+ mapM_ (listStoreAppend store) dats
+
+
+-- |
+--
+--
+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
+
+ _ -> return False
+
+
diff --git a/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs b/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/BreakPointTable.hs
@@ -0,0 +1,249 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.BreakPointTable (
+ BreakPointListStore
+, BreakPointData(..)
+, BreakPointDataKey
+, getBreakCondition
+, DeleteAllBreakBTClickedEventHandler
+, BreakPointTableDoubleClickedHandler
+, setupBreakPointTable
+, createBreakPointListStore
+, addBreakPoint2Table
+, deleteFromBreakPointListStore
+, getBreakPointList
+, updateBreakPointTable
+, findBreakPointData
+, highLightBreakPointTableRow
+) where
+
+-- モジュール
+import Phoityne.Constant
+import Phoityne.IO.GUI.GTK.Constant
+import Phoityne.IO.GUI.GTK.Utility
+
+-- システム
+import Graphics.UI.Gtk
+import Control.Monad.IO.Class
+import System.Log.Logger
+import qualified Data.List as L
+
+-- |
+--
+--
+data BreakPointData =
+ BreakPointData {
+ moduleNameBreakPointData :: String
+ , filePathBreakPointData :: FilePath
+ , lineNoBreakPointData :: Int
+ , breakNoBreakPointData :: Maybe Int
+ , conditionBreakPointData :: String
+ } deriving (Show, Read, Eq, Ord)
+
+-- |
+--
+--
+type BreakPointTableDoubleClickedHandler = BreakPointData -> IO ()
+
+-- |
+--
+--
+type BreakPointDataKey = (FilePath, Int)
+
+-- |
+--
+--
+type BreakPointListStore = ListStore BreakPointData
+
+-- |
+--
+--
+type DeleteAllBreakBTClickedEventHandler = IO ()
+
+-- |
+--
+--
+createBreakPointListStore :: IO BreakPointListStore
+createBreakPointListStore = listStoreNew ([] :: [BreakPointData])
+
+-- |
+--
+--
+setupBreakPointTable :: Builder
+ -> BreakPointListStore
+ -> BreakPointTableDoubleClickedHandler
+ -> IO ()
+setupBreakPointTable builder store evh = 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
+
+ setFont treeView
+ widgetShowAll treeView
+
+
+-- |
+--
+--
+breakPointsConditionEditedHandler :: TreeView -> ListStore BreakPointData -> TreePath -> String -> IO ()
+breakPointsConditionEditedHandler treeView listStore treePath value = do
+ treeViewGetModel treeView >>= \case
+ Nothing -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]model not found."
+ Just model -> withModel model
+
+ where
+ withModel model = treeModelGetIter model treePath >>= \case
+ Nothing -> errorM _LOG_NAME $ "[breakPointsConditionEditedHandler]treeIter not found."
+ Just iter -> newData iter >>= listStoreSetValue listStore (listStoreIterToIndex iter)
+
+ newData iter = do
+ dat <- listStoreGetValue listStore (listStoreIterToIndex iter)
+ return dat{conditionBreakPointData = value}
+
+-- |
+--
+--
+breakPointTableDoubleClickedHandler :: TreeView -> ListStore BreakPointData -> BreakPointTableDoubleClickedHandler -> EventM EButton Bool
+breakPointTableDoubleClickedHandler self listStore evh = eventClick >>= \case
+ DoubleClick -> liftIO $ do
+ sel <- treeViewGetSelection self
+ treeSelectionGetSelected sel >>= \case
+ Nothing -> return False
+ Just iter -> do
+ let idx = listStoreIterToIndex iter
+ bpDat <- listStoreGetValue listStore idx
+ evh bpDat
+ return False
+
+ _ -> return False
+
+
+-- |
+--
+--
+addBreakPoint2Table :: BreakPointListStore -> BreakPointData -> IO ()
+addBreakPoint2Table = add2ListStore
+
+-- |
+--
+--
+deleteFromBreakPointListStore :: ListStore BreakPointData -> BreakPointDataKey -> IO ()
+deleteFromBreakPointListStore store (path, lineNo) =
+ treeModelForeach (castToTreeModel store) deleteData
+ where
+ deleteData iter = do
+ let idx = listStoreIterToIndex iter
+ (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx
+ if (curPath == path) && (curLineNo == lineNo) then listStoreRemove store idx >> return True
+ else return False
+
+-- |
+--
+--
+updateBreakPointTable :: ListStore BreakPointData -> BreakPointDataKey -> BreakPointData -> IO ()
+updateBreakPointTable store (path, lineNo) newDat = do
+ treeModelForeach (castToTreeModel store) updateData
+ where
+ updateData iter = do
+ let idx = listStoreIterToIndex iter
+ (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue store idx
+ if (curPath == path) && (curLineNo == lineNo) then listStoreSetValue store idx newDat >> return True
+ else return False
+
+-- |
+--
+--
+findBreakPointData :: ListStore BreakPointData -> BreakPointDataKey -> IO (Maybe BreakPointData)
+findBreakPointData store (path, lineNo) = do
+ xs <- listStoreToList store
+ return $ L.find findData xs
+ where
+ findData (BreakPointData _ curPath curLineNo _ _) = (curPath == path) && (curLineNo == lineNo)
+
+-- |
+--
+--
+getBreakPointList :: ListStore a -> IO [a]
+getBreakPointList = listStoreToList
+
+-- |
+--
+--
+highLightBreakPointTableRow :: Builder -> ListStore BreakPointData -> BreakPointDataKey -> IO ()
+highLightBreakPointTableRow builder listStore (path, lineNo) = do
+ treeView <- builderGetObject builder castToTreeView _WIDGET_NAME_BREAK_POINT_TREE_VIEW
+ sel <- treeViewGetSelection treeView
+ treeViewGetModel treeView >>= \case
+ Nothing -> errorM _LOG_NAME $ "[highLightBreakPointTableRow]invalid highlight break point table."
+ Just model -> treeModelForeach model $ highLight sel
+
+ where
+ highLight sel iter = do
+ let idx = listStoreIterToIndex iter
+ (BreakPointData _ curPath curLineNo _ _) <- listStoreGetValue listStore idx
+ if (L.isSuffixOf path curPath) && (curLineNo == lineNo) then treeSelectionSelectIter sel iter >> return True
+ else return False
+
+-- |
+--
+--
+getBreakCondition :: ListStore BreakPointData -> BreakPointDataKey -> IO String
+getBreakCondition listStore (path, lineNo) = do
+ bps <- listStoreToList listStore
+ case L.find go bps of
+ Nothing -> do
+ errorM _LOG_NAME $ "[getBreakCondition]invalid break point data. " ++ path ++ ":" ++ show lineNo
+ return ""
+ Just (BreakPointData _ _ _ _ condStr) -> return condStr
+ where
+ go (BreakPointData _ curPath curLineNo _ _) = (L.isSuffixOf curPath path) && (curLineNo == lineNo)
+
diff --git a/app/Phoityne/IO/GUI/GTK/ConsoleView.hs b/app/Phoityne/IO/GUI/GTK/ConsoleView.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/ConsoleView.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.ConsoleView (
+ ConsoleDoubleClickedHandler
+, setupConsoleView
+, putStrConsole
+, putStrLnConsole
+, clearConsole
+) where
+
+-- モジュール
+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 qualified Data.Text as T
+
+-- |
+--
+--
+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
+
+
+-- |
+--
+--
+clearConsole :: Builder -> IO ()
+clearConsole builder = do
+ 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
+
+ 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
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/Constant.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.Constant
+ where
+
+-- モジュール
+
+-- システム
+import qualified Data.Text as T
+import System.FilePath
+
+-- |
+--
+--
+_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"
+
+_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_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_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"
+
+
diff --git a/app/Phoityne/IO/GUI/GTK/FolderTree.hs b/app/Phoityne/IO/GUI/GTK/FolderTree.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/FolderTree.hs
@@ -0,0 +1,466 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# 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
+, 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 Control.Monad.IO.Class
+import Data.String.Utils
+import qualified Data.Tree as TR
+import qualified Data.Text as T
+
+-- |
+--
+--
+type FolderTreeStore = TreeStore NodeData
+
+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
+
+ compare (FileNodeData _ _ _) (FolderNodeData _ _ _) = GT
+
+-- |
+--
+--
+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]
+
+
+-- |
+-- 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
+ -> FolderTreeReplaceAction
+ -> 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
+
+ setFont treeView
+
+ widgetShowAll colLabel
+ widgetShowAll treeView
+
+
+
+-- |
+-- Event Handler
+--
+folderTreeClickedHandler :: TreeView
+ -> FolderTreeDoubleClickedHandler
+ -> FolderTreePopupHandler
+ -> EventM EButton Bool
+folderTreeClickedHandler treeView doubleEH popupEH = do
+ bt <- eventButton
+ ck <- eventClick
+
+ (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
+
+-- |
+-- 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 (endswith _HS_FILE_EXT path)
+
+
+ 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
+
+-- |
+-- 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
+ Nothing -> return ()
+ Just iter -> do
+ path <- treeIter2Path store iter
+ treeViewRowExpanded treeView path >>= \case
+ True -> treeViewCollapseRow treeView path >> return ()
+ False -> treeViewExpandToPath treeView path
+
+-- |
+--
+--
+expandFolderTree :: Builder -> TreeStore NodeData -> IO ()
+expandFolderTree builder store = do
+ 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
+ Nothing -> return ()
+ Just iter -> do
+ path <- treeIter2Path store iter
+ treeViewRowExpanded treeView path >>= \case
+ True -> treeViewCollapseRow treeView path >> return ()
+ False -> return ()
diff --git a/app/Phoityne/IO/GUI/GTK/Interface.hs b/app/Phoityne/IO/GUI/GTK/Interface.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/Interface.hs
@@ -0,0 +1,498 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.Interface (
+ module Phoityne.IO.GUI.GTK.ConsoleView
+, module Phoityne.IO.GUI.GTK.BindingTable
+, module Phoityne.IO.GUI.GTK.BreakPointTable
+, module Phoityne.IO.GUI.GTK.TextEditor
+, module Phoityne.IO.GUI.GTK.TraceTable
+, module Phoityne.IO.GUI.GTK.FolderTree
+, module Phoityne.IO.GUI.GTK.SearchResultTable
+
+-- Main
+, WidgetStore
+, MainWindowCloseEventHandler
+, MainWindowKeyPressEventHandler
+, CallbackHandlerId
+, getBuilder
+, start
+, setupMainWindow
+, addCallback
+, delCallback
+
+-- ToolButton
+, DebugStartBTClickedEventHandler
+, DebugStopBTClickedEventHandler
+, StepOverBTClickedEventHandler
+, StepInBTClickedEventHandler
+, BuildBTClickedEventHandler
+, SaveBTClickedEventHandler
+, IndentBTClickedEventHandler
+, UnIndentBTClickedEventHandler
+, CommentBTClickedEventHandler
+, UnCommentBTClickedEventHandler
+, setupToolButton
+, setupDebugButtonOn
+, setupDebugButtonOff
+, setupBuildButtonOn
+, setupBuildButtonOff
+, isDebugStart
+, isBuildStart
+
+-- Dialog
+, getNameByFolderTreeDialog
+, getSearchKeyBySearchDialog
+, getSearchKeyFromSearchDialog
+, getReplaceByReplaceDialog
+, initSearchDialog
+, initReplaceDialog
+) 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 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 ()
+
+type UnIndentBTClickedEventHandler = IO ()
+
+type CommentBTClickedEventHandler = IO ()
+
+type UnCommentBTClickedEventHandler = IO ()
+
+
+-- |
+--
+--
+type CallbackHandlerId = HandlerId
+
+
+
+-- |=====================================================================
+-- Main
+--
+
+-- |
+-- priorityHighIdle
+-- priorityDefaultIdle
+--
+addCallback :: IO Bool -> IO CallbackHandlerId
+addCallback f = idleAdd f priorityDefaultIdle
+
+
+-- |
+--
+--
+delCallback :: CallbackHandlerId -> IO ()
+delCallback = idleRemove
+
+
+-- |
+--
+--
+getGladeFile :: IO String
+getGladeFile = getDataFileName _GLADE_FILE
+
+
+-- |
+--
+--
+getBuilder :: IO Builder
+getBuilder = do
+ initGUI
+
+ builder <- builderNew
+ gfile <- getGladeFile
+ builderAddFromFile builder gfile
+
+ 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
+setupMainWindow :: Builder
+ -> MainWindowCloseEventHandler
+ -> MainWindowKeyPressEventHandler
+ -> IO ()
+setupMainWindow builder 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
+
+ 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
+
+
+-- |
+-- 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)
+
+-- |
+--
+--
+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
+ widgetGetSensitive bt >>= return . not
+
+
+-- |=====================================================================
+-- 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
+
+ widgetHide dialog
+
+ 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
+
+ widgetHide dialog
+
+ 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
+ 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)
+
+-- |
+--
+--
+initSearchDialog :: Builder -> IO ()
+initSearchDialog builder = do
+ 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 ""
+
+
+-- |=====================================================================
+--
+--
+
+
+-- |
+--
+--
+setupToolButton :: Builder
+ -> DebugStartBTClickedEventHandler
+ -> DebugStopBTClickedEventHandler
+ -> StepOverBTClickedEventHandler
+ -> StepInBTClickedEventHandler
+ -> ContinueBTClickedEventHandler
+ -> BuildBTClickedEventHandler
+ -> DeleteAllBreakBTClickedEventHandler
+ -> SaveBTClickedEventHandler
+ -> IndentBTClickedEventHandler
+ -> UnIndentBTClickedEventHandler
+ -> CommentBTClickedEventHandler
+ -> UnCommentBTClickedEventHandler
+ -> IO ()
+setupToolButton builder debugStartEvh debugStopEvh stepOverEvh stepInEvh continueEvh buildEvh deleteEvh saveEvh indentEvh unIndentEvh commentEvh unCommentEvh = do
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START
+ onToolButtonClicked bt debugStartEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP
+ onToolButtonClicked bt debugStopEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER
+ onToolButtonClicked bt stepOverEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN
+ onToolButtonClicked bt stepInEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE
+ onToolButtonClicked bt continueEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD
+ onToolButtonClicked bt buildEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DELETE
+ onToolButtonClicked bt deleteEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_SAVE
+ onToolButtonClicked bt saveEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_INDENT
+ onToolButtonClicked bt indentEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNINDENT
+ onToolButtonClicked bt unIndentEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_COMMENT
+ onToolButtonClicked bt commentEvh
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNCOMMENT
+ onToolButtonClicked bt unCommentEvh
+
+ setupDebugButtonOff builder
+
+ return ()
+
+
+
+-- |
+--
+--
+setupDebugButtonOn :: Builder -> IO ()
+setupDebugButtonOn builder = do
+
+ 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_STEP_OVER
+ widgetSetSensitive bt True
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN
+ widgetSetSensitive bt True
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE
+ widgetSetSensitive bt True
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD
+ widgetSetSensitive bt False
+
+-- |
+--
+--
+setupDebugButtonOff :: Builder -> IO ()
+setupDebugButtonOff builder = do
+
+ 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_STEP_OVER
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD
+ widgetSetSensitive bt True
+
+
+-- |
+--
+--
+setupBuildButtonOn :: Builder -> IO ()
+setupBuildButtonOn builder = do
+
+ 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_STEP_OVER
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD
+ widgetSetSensitive bt True
+
+-- |
+--
+--
+setupBuildButtonOff :: Builder -> IO ()
+setupBuildButtonOff builder = do
+
+ 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_STEP_OVER
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE
+ widgetSetSensitive bt False
+
+ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD
+ widgetSetSensitive bt False
+
+
+-- |=====================================================================
+--
+--
+
+
+
diff --git a/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs b/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/SearchResultTable.hs
@@ -0,0 +1,287 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.SearchResultTable (
+ SearchResultListStore
+, SearchResultOffset
+, 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 Control.Monad.IO.Class
+
+-- |
+--
+--
+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 ()
+
+
+-- |
+--
+--
+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
+
+ 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
+
+
+-- |
+--
+--
+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
+ notebookSetCurrentPage note idx
+
+-- |
+--
+--
+addSearchReslutTable :: ListStore SearchResultData -> SearchResultData -> IO ()
+addSearchReslutTable store dat = listStoreAppend store dat >> return ()
+
+-- |
+--
+--
+clearSearchResultTable :: ListStore SearchResultData -> IO ()
+clearSearchResultTable = listStoreClear
+
+-- |
+--
+--
+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
+ 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 store (Just model) (Just (path, lineNo))= do
+ sel <- treeViewGetSelection treeView
+ treeModelGetIterFirst model >>= \case
+ Nothing -> return ()
+ Just firstIter -> findIter firstIter >>= \case
+ Nothing -> treeSelectionSelectIter sel firstIter
+ Just curIter -> do
+ treeSelectionSelectIter sel curIter
+ treePath <- treeModelGetPath model curIter
+ treeViewScrollToCell treeView (Just treePath) Nothing Nothing
+
+ where
+ findIter iter = do
+ (SearchResultData pathSR lineNoSR _ _ _) <- listStoreGetValue store (listStoreIterToIndex iter)
+ if (path == pathSR) && (lineNo <= lineNoSR) then return (Just iter)
+ else treeModelIterNext model iter >>= \case
+ 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
+ Just nextIter -> do
+ treeSelectionSelectIter sel nextIter
+ treePath <- treeModelGetPath model nextIter
+ 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)
+
+-- |
+--
+--
+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 _ _ 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
+
diff --git a/app/Phoityne/IO/GUI/GTK/TextEditor.hs b/app/Phoityne/IO/GUI/GTK/TextEditor.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/TextEditor.hs
@@ -0,0 +1,772 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.TextEditor (
+ TextEditorData(..)
+, LineTextDoubleClickedHandler
+, CodeNoteCloseEventHandler
+, CodeTextKeyPressEventHandler
+, CodeBufferChangedEventHandler
+, CodeBufferDeleteRangeEventHandler
+, CodeBufferInsertTextEventHandler
+, setupCodeNote
+, activateCodeNote
+, highLightBreakPoint
+, offLightBreakPoint
+, addBreakPointTagAtLine
+, isCurrentTextEditor
+, getCodeViewContent
+, isTextEditorModified
+, setTextEditorModified
+, getCodeTextLineNumber
+, blockIndentTextEditor
+, blockUnIndentTextEditor
+, blockCommentTextEditor
+, blockUnCommentTextEditor
+, setContent2TextEditor
+, setCursorOnTextEditor
+, deleteRangeOnTextEditor
+, insertText2TextEditor
+, getSelectedText
+, deleteBreakPointTag
+, deleteBreakPointTagAtLine
+, updateBreakPointTag
+, 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 Data.String.Utils
+import qualified Control.Exception as E
+import qualified Data.Text as T
+import qualified Data.ByteString as BS
+
+-- |
+--
+--
+type LineTextDoubleClickedHandler
+ = Bool -- isTagExists
+ -> Int -- lineNo
+ -> IO ()
+
+-- |
+--
+--
+type HSCode = BS.ByteString
+
+-- |
+--
+--
+type CodeNoteCloseEventHandler = TextEditorData -> IO ()
+
+-- |
+--
+--
+data TextEditorData =
+ TextEditorData {
+ lineTextEditorData :: TextView
+ , codeTextEditorData :: TextView
+ , boxTextEditorData :: HBox
+ , tabLabelTextEditorData :: Label
+ } deriving (Eq)
+
+-- |
+--
+--
+type CodeTextKeyPressEventHandler = String -> Bool -> Bool -> Bool -> Int -> IO Bool
+
+-- |
+--
+--
+type CodeBufferChangedEventHandler = IO ()
+
+-- |
+--
+--
+type CodeBufferDeleteRangeEventHandler = (Int, Int) -> (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
+ iter <- textBufferGetIterAtLineOffset buf startLineNo startColNo
+ forwardTextIter iter $ length str
+ lineNo <- textIterGetLine iter
+ colNo <- textIterGetLineOffset iter
+ return (lineNo, colNo)
+
+
+-- |
+--
+--
+setupCodeNote :: Builder
+ -> String -- ファイル名
+ -> FilePath -- ファイルパス
+ -> HSCode -- コンテンツ
+ -> CodeNoteCloseEventHandler
+ -> LineTextDoubleClickedHandler
+ -> Maybe Int -- スクロールライン
+ -> CodeTextKeyPressEventHandler
+ -> CodeBufferChangedEventHandler
+ -> CodeBufferDeleteRangeEventHandler
+ -> CodeBufferInsertTextEventHandler
+ -> IO TextEditorData
+setupCodeNote builder name path code evh lineViewEvh _ codeKeyEVH bufEVH delRangeEVH insertTextEVH = do
+ img <- imageNewFromIcon (T.pack "window-close") 8
+ 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
+
+ -- ノートブックに新規ページの生成
+ 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)
+
+ setFont note
+
+ widgetShowAll note
+
+ -- activateCodeNote builder textEditor lineNo
+
+ return textEditor
+
+-- |
+--
+--
+createTextEditor :: Builder
+ -> HSCode
+ -> LineTextDoubleClickedHandler
+ -> Label
+ -> CodeTextKeyPressEventHandler
+ -> CodeBufferChangedEventHandler
+ -> CodeBufferDeleteRangeEventHandler
+ -> CodeBufferInsertTextEventHandler
+ -> 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 True
+ 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
+
+ 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
+ _ <- 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
+
+ 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
+
+ codeTextBufferChangedHandler lineBuf codeBuf _ = do
+ ll <- textBufferGetLineCount lineBuf
+ cl <- textBufferGetLineCount codeBuf
+ updateLineNo lineBuf codeBuf ll cl
+
+ updateLineNo lineBuf _ ll cl
+ | ll == cl = return ()
+ | ll < cl = do
+ let lineTxt = "\n" ++ createLineNoText [ll+1 .. cl] ""
+ endIter <- textBufferGetEndIter lineBuf
+ textBufferInsert lineBuf endIter lineTxt
+ | otherwise = do
+ startIter <- textBufferGetIterAtLine lineBuf (cl-1)
+ textIterForwardToLineEnd startIter
+ endIter <- textBufferGetEndIter lineBuf
+ textBufferDelete lineBuf startIter endIter
+
+ codeTextDeleteRangeEventHandler view evh si ei = do
+ slineNo <- textIterGetLine si
+ sColNo <- textIterGetLineOffset si
+ elineNo <- textIterGetLine ei
+ eColNo <- textIterGetLineOffset ei
+
+ buf <- textViewGetBuffer view
+ str <- textBufferGetText buf si ei False
+ evh (slineNo, sColNo) (elineNo, eColNo) str
+
+ codeTextInsertTextEventHandler _ evh si str = do
+ 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
+
+
+-- |
+--
+--
+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."
+
+ window <- builderGetObject builder castToWindow _WINDOW_NAME
+ widgetShowAll window
+ forceEvent
+
+ let codeTextView = codeTextEditorData wid
+ codeBuf <- textViewGetBuffer codeTextView
+ iter <- textBufferGetIterAtLine codeBuf lineNo
+ _ <- textViewScrollToIter codeTextView iter 0.0 (Just (0.0, 0.5))
+
+ 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
+ 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
+
+-- |
+--
+--
+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
+
+-- |
+-- 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
+
+-- |
+--
+--
+highLightBreakPoint :: TextEditorData -> Int -> Int -> Int -> Int -> IO ()
+highLightBreakPoint textEditor sl sc el ec = do
+
+ let codeTextView = codeTextEditorData textEditor
+ codeBuf <- textViewGetBuffer codeTextView
+ --tagTable <- textBufferGetTagTable codeBuf
+
+ startLine <- normalizeLine codeBuf sl
+ startCol <- normalizeColumn codeBuf startLine sc
+
+ endLine <- normalizeLine codeBuf el
+ endCol <- normalizeColumn codeBuf endLine ec
+
+ startIter <- textBufferGetIterAtLineOffset codeBuf startLine startCol
+ endIter <- textBufferGetIterAtLineOffset codeBuf endLine (endCol + 1)
+
+ textBufferPlaceCursor codeBuf endIter
+ textBufferSelectRange codeBuf startIter endIter
+
+ where
+ normalizeLine buf l = do
+ nl <- normalizeLine_ buf l
+ return $ if 0 > nl then 0 else nl
+
+ normalizeLine_ buf l = do
+ allLines <- textBufferGetLineCount buf
+ return $ if l > allLines then allLines - 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
+
+
+-- |
+--
+--
+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
+
+-- |
+--
+--
+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
+
+-- |
+--
+--
+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
+ textBufferSetModified buf isModified
+
+
+-- |
+--
+--
+codeTextButtonPressEventHandler :: TextView -> EventM EButton Bool
+codeTextButtonPressEventHandler textView = eventButton >>= \case
+ RightButton -> liftIO $ do
+ buf <- textViewGetBuffer textView
+ clip <- widgetGetClipboard textView selectionPrimary
+ textBufferHasSelection buf >>= \case
+ False -> textBufferPasteClipboardAtCursor buf clip True >> return True
+ True -> textBufferCopyClipboard buf clip >> return True
+ _ -> return False
+
+
+-- |
+-- Event Handler
+--
+codeTextKeyPressEventHandler :: TextView -> TextView -> CodeTextKeyPressEventHandler -> EventM EKey Bool
+codeTextKeyPressEventHandler lineTextView codeTextView evh = do
+ name <- eventKeyName
+ mods <- eventModifier
+
+ liftIO $ do
+ buf <- textViewGetBuffer codeTextView
+ mark <- textBufferGetInsert buf
+ iter <- textBufferGetIterAtMark buf mark
+ lineNo <- textIterGetLine iter
+
+ buf <- textViewGetBuffer lineTextView
+ iter <- textBufferGetIterAtLine buf lineNo
+ isTagExists <- textIterBeginsTag iter Nothing
+
+ evh (T.unpack name) (elem Shift mods) (elem Control mods) isTagExists lineNo
+
+-- |
+--
+--
+getCodeTextLineNumber :: TextEditorData -> IO (Int, Int)
+getCodeTextLineNumber (TextEditorData _ codeView _ _) = do
+ buf <- textViewGetBuffer codeView
+ mark <- textBufferGetInsert buf
+ iter <- textBufferGetIterAtMark buf mark
+ lineNo <- textIterGetLine iter
+ colNo <- textIterGetLineOffset iter
+ return (lineNo, colNo)
+
+-- |
+--
+--
+blockIndentTextEditor :: TextEditorData -> IO ()
+blockIndentTextEditor te@(TextEditorData _ codeView _ _) = do
+ (startLine, endLine) <- getSelectedLineNumbers te
+ buf <- textViewGetBuffer codeView
+ insertIndent buf startLine endLine
+ where
+ insertIndent buf lineNo endNo = do
+ iter <- textBufferGetIterAtLine buf lineNo
+ textBufferInsert buf iter _INDENT_SPACE
+ if lineNo == endNo then return ()
+ else insertIndent buf (lineNo+1) endNo
+
+-- |
+--
+--
+blockUnIndentTextEditor :: TextEditorData -> IO ()
+blockUnIndentTextEditor te@(TextEditorData _ codeView _ _) = do
+ (startLine, endLine) <- getSelectedLineNumbers te
+ buf <- textViewGetBuffer codeView
+ deleteIndent buf startLine endLine
+ where
+ deleteIndent buf lineNo endNo = do
+ iter <- textBufferGetIterAtLine buf lineNo
+ next <- textIterCopy iter
+
+ forwardTextIter next 2 >>= \case
+ Nothing -> return ()
+ Just endIter -> do
+ indent <- textBufferGetText buf iter endIter False
+ when (_INDENT_SPACE == indent) $ textBufferDelete buf iter endIter
+
+ if lineNo == endNo then return ()
+ else deleteIndent buf (lineNo+1) endNo
+
+-- |
+--
+--
+blockCommentTextEditor :: TextEditorData -> IO ()
+blockCommentTextEditor te@(TextEditorData _ codeView _ _) = do
+ (startLine, endLine) <- getSelectedLineNumbers te
+ buf <- textViewGetBuffer codeView
+ insertComment buf startLine endLine
+ where
+ insertComment buf lineNo endNo = do
+ iter <- textBufferGetIterAtLine buf lineNo
+ cnt <- getSpaceCount buf iter
+
+ when (cnt /= (-1)) $ do
+ forwardTextIter iter cnt >>= \case
+ Nothing -> return ()
+ Just startIter -> textBufferInsert buf startIter _COMMENT_TAG
+
+ if lineNo == endNo then return ()
+ else insertComment buf (lineNo+1) endNo
+
+ getSpaceCount buf iter = do
+ isEndLine <- textIterEndsLine iter
+ isEndBuf <- textIterIsEnd iter
+
+ if isEndLine || isEndBuf then return (-1) else do
+ endIter <- textIterCopy iter
+ _ <- textIterForwardToLineEnd endIter
+ str <- textBufferGetText buf iter endIter False
+ return $ length $ takeWhile (== ' ') str
+
+-- |
+--
+--
+blockUnCommentTextEditor :: TextEditorData -> IO ()
+blockUnCommentTextEditor te@(TextEditorData _ codeView _ _) = do
+ (startLine, endLine) <- getSelectedLineNumbers te
+ buf <- textViewGetBuffer codeView
+ deleteComment buf startLine endLine
+
+ where
+ deleteComment buf lineNo endNo = do
+ iter <- textBufferGetIterAtLine buf lineNo
+
+ (isCmnt, idx) <- getCommentInfo buf iter
+ iterMay <- forwardTextIter iter idx
+ when isCmnt $ deleteCommentTag buf iterMay
+
+ if lineNo == endNo then return ()
+ else deleteComment buf (lineNo+1) endNo
+
+ deleteCommentTag _ Nothing = return ()
+ deleteCommentTag buf (Just iter) = do
+ next <- textIterCopy iter
+ forwardTextIter next (length _COMMENT_TAG) >>= \case
+ Nothing -> return ()
+ Just endIter -> textBufferDelete buf iter endIter
+
+ getCommentInfo :: TextBuffer -> TextIter -> IO (Bool, Int)
+ getCommentInfo buf iter = do
+ endIter <- textIterCopy iter
+ textIterForwardToLineEnd endIter >>= \case
+ False -> return (False, 0) -- 最終行はFalseとなる問題あり。
+ True -> do
+ str <- textBufferGetText buf iter endIter False
+ 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
+ textBufferHasSelection buf >>= \case
+ True -> do
+ (startIter, endIter) <- textBufferGetSelectionBounds buf
+ s <- textIterGetLine startIter
+ e <- textIterGetLine endIter
+ return (s, e)
+ False -> do
+ (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 (TextEditorData _ codeView _ _) lineNo colNo = do
+ buf <- textViewGetBuffer codeView
+ iter <- textBufferGetIterAtLineOffset buf lineNo colNo
+ textBufferPlaceCursor buf iter
+ 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
+ startIter <- textBufferGetIterAtLineOffset buf startLineNo startColNo
+ endIter <- textBufferGetIterAtLineOffset buf endLineNo endColNo
+ textBufferDelete buf startIter endIter
+
+-- |
+--
+--
+getSelectedText :: TextEditorData -> IO String
+getSelectedText (TextEditorData _ codeView _ _) = do
+ buf <- textViewGetBuffer codeView
+ textBufferHasSelection buf >>= \case
+ True -> do
+ (startIter, endIter) <- textBufferGetSelectionBounds buf
+ textBufferGetText buf startIter endIter False
+ False -> return ""
+
diff --git a/app/Phoityne/IO/GUI/GTK/TraceTable.hs b/app/Phoityne/IO/GUI/GTK/TraceTable.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/TraceTable.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.TraceTable (
+ TraceData(..)
+, TraceDataListStore
+, TraceTableDoubleClickedHandler
+, createTraceDataListStore
+, setupTraceTable
+, updateTraceTable
+) where
+
+-- モジュール
+import Phoityne.IO.GUI.GTK.Constant
+import Phoityne.IO.GUI.GTK.Utility
+
+-- システム
+import Graphics.UI.Gtk
+import Control.Monad.IO.Class
+
+-- |
+--
+--
+data TraceData = TraceData {
+ traceIdTraceData :: String
+ , functionTraceData :: String
+ , filePathTraceData :: String
+ } deriving (Show, Read, Eq, Ord)
+
+-- |
+--
+--
+type TraceDataListStore = ListStore TraceData
+
+-- |
+--
+--
+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
+
+
+-- |
+--
+--
+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
+
+
diff --git a/app/Phoityne/IO/GUI/GTK/Utility.hs b/app/Phoityne/IO/GUI/GTK/Utility.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/GUI/GTK/Utility.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Phoityne.IO.GUI.GTK.Utility
+ where
+
+-- モジュール
+import Phoityne.IO.GUI.GTK.Constant
+
+-- システム
+import Graphics.UI.Gtk
+import qualified Control.Exception as E
+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
+
+ where
+ handlers = [ E.Handler someExcept ]
+ 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 ()
+
+-- |
+--
+--
+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 ()
+
+-- |
+--
+--
+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
+
+-- |
+--
+--
+forwardTextIter :: TextIter -> Int -> IO (Maybe TextIter)
+forwardTextIter iter 0 = return $ Just iter
+forwardTextIter iter count = textIterForwardChar iter >>= \case
+ False -> return Nothing
+ True -> forwardTextIter iter (count-1)
+
diff --git a/app/Phoityne/IO/Main.hs b/app/Phoityne/IO/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/Main.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
+
+module Phoityne.IO.Main (run) where
+
+-- モジュール
+import Phoityne.Constant
+import qualified Phoityne.Argument as A
+import qualified Phoityne.IO.Control as CTRL
+
+-- システム
+import System.IO
+import Data.Either.Utils
+import Safe
+import qualified Control.Exception as E
+import qualified System.IO.Error as E
+import qualified Data.ConfigFile as C
+import qualified System.Console.CmdArgs as CMD
+import qualified System.Log.Logger as L
+import qualified System.Log.Formatter as L
+import qualified System.Log.Handler as LH
+import qualified System.Log.Handler.Simple as LHS
+
+-- |
+-- アプリケーションメイン
+--
+run :: IO Int
+run = flip E.catches handlers $ do
+
+ -- コマンドライン引数設定
+ args <- getArgs
+
+ -- INI設定ファイルのRead
+ iniSet <- loadIniFile args
+
+ -- Loggerのセットアップ
+ setupLogger iniSet
+
+ -- ロジック実行
+ flip E.finally finalProc $ do
+ CTRL.run args iniSet
+
+ where
+ handlers = [ E.Handler helpExcept
+ , E.Handler ioExcept
+ , E.Handler someExcept
+ ]
+ finalProc = L.removeAllHandlers
+ helpExcept (_ :: A.HelpExitException) = return 0
+ ioExcept (e :: E.IOException) = print e >> return 1
+ someExcept (e :: E.SomeException) = print e >> return 1
+
+-- |
+-- 引数データの取得
+--
+getArgs :: IO A.ArgData
+getArgs = E.catches (CMD.cmdArgs A.config) handlers
+ where
+ handlers = [E.Handler someExcept]
+ someExcept (e :: E.SomeException) = if
+ | "ExitSuccess" == show e -> E.throw A.HelpExitException
+ | otherwise -> E.throwIO e
+
+-- |
+-- INI設定ファイルデータの取得
+--
+loadIniFile :: A.ArgData -- コマンドライン引数
+ -> IO C.ConfigParser -- INI設定
+loadIniFile args = do
+ cp <- if null (A.file args) then return $ forceEither $ C.readstring C.emptyCP defaultIniSetting
+ else forceEither <$> C.readfile C.emptyCP (A.file args)
+
+ return cp{ C.accessfunc = C.interpolatingAccess 5 }
+
+-- |
+-- デフォルトINI設定
+--
+defaultIniSetting :: String
+defaultIniSetting = unlines [
+ "[DEFAULT]"
+ , "work_dir = ./"
+ , ""
+ , "[LOG]"
+ , "file = %(work_dir)sphoityne.log"
+ , "level = INFO"
+ , ""
+ , "[PHOITYNE]"
+ , "target = ."
+ ]
+
+-- |
+-- Loggerのセットアップ
+--
+setupLogger :: C.ConfigParser -- INI設定
+ -> IO () -- なし
+setupLogger cp = do
+ let logFile = forceEither $ C.get cp _INI_SEC_LOG _INI_LOG_FILE
+ logLevel = forceEither $ C.get cp _INI_SEC_LOG _INI_LOG_LEVEL
+
+ level <- case readMay logLevel of
+ Just a -> return a
+ Nothing -> E.throwIO . E.userError $ "invalid log level[" ++ logLevel ++ "]"
+
+ logStream <- openFile logFile AppendMode
+ hSetEncoding logStream utf8
+
+ logH <- LHS.streamHandler logStream level
+ logSTD <- LHS.streamHandler stdout level
+
+ let logHandle = logH {LHS.closeFunc = hClose}
+ logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT
+ logHandler = LH.setFormatter logHandle logFormat
+ logHndlerSTD = LH.setFormatter logSTD logFormat
+
+ L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle])
+ L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler, logHndlerSTD]
+ L.updateGlobalLogger _LOG_NAME $ L.setLevel level
+
diff --git a/app/Phoityne/IO/Utility.hs b/app/Phoityne/IO/Utility.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/IO/Utility.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module Phoityne.IO.Utility where
+
+-- システム
+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
+
+-- |
+--
+--
+getReadHandleEncoding :: IO TextEncoding
+getReadHandleEncoding = if
+ | Windows == buildOS -> mkTextEncoding "CP932"
+ | otherwise -> return utf8
+
+-- |
+--
+--
+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
+
+-- |
+--
+--
+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
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/Type.hs
@@ -0,0 +1,5 @@
+module Phoityne.Type where
+
+
+
+
diff --git a/app/Phoityne/Utility.hs b/app/Phoityne/Utility.hs
new file mode 100644
--- /dev/null
+++ b/app/Phoityne/Utility.hs
@@ -0,0 +1,68 @@
+
+module Phoityne.Utility where
+
+-- システム
+import Data.Either.Utils
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.List as L
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+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
+
+
+-- |
+-- UTF8文字列をByteStringへの変換
+--
+str2bs :: String -> BS.ByteString
+str2bs = TE.encodeUtf8 . T.pack
+
+-- |
+-- ByteStringをUTF8文字列への変換
+--
+bs2str :: BS.ByteString -> String
+bs2str = T.unpack. TE.decodeUtf8
+
+-- |
+-- UTF8文字列をLazyByteStringへの変換
+--
+str2lbs :: String -> LBS.ByteString
+str2lbs = TLE.encodeUtf8 . TL.pack
+
+-- |
+-- LazyByteStringをUTF8文字列への変換
+--
+lbs2str :: LBS.ByteString -> String
+lbs2str = TL.unpack. TLE.decodeUtf8
+
+-- |
+-- INI設定の指定したセクションに含まれる
+-- すべて設定項目を返す。
+--
+getIniItems :: CFG.ConfigParser
+ -> CFG.SectionSpec
+ -> [(CFG.OptionSpec, String)]
+getIniItems cp sec = foldr go [] opts
+ where
+ opts = forceEither $ CFG.options cp sec
+ go opt acc = let value = forceEither $ CFG.get cp sec opt in
+ (opt, value) : acc
+
+
+-- |
+--
+--
+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/HaskellLogoStyPreview-1.png b/conf/HaskellLogoStyPreview-1.png
new file mode 100644
Binary files /dev/null and b/conf/HaskellLogoStyPreview-1.png differ
diff --git a/conf/Phoityne.glade b/conf/Phoityne.glade
new file mode 100644
--- /dev/null
+++ b/conf/Phoityne.glade
@@ -0,0 +1,1405 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/conf/h.ico b/conf/h.ico
new file mode 100644
Binary files /dev/null and b/conf/h.ico differ
diff --git a/conf/h2.ico b/conf/h2.ico
new file mode 100644
Binary files /dev/null and b/conf/h2.ico differ
diff --git a/phoityne.cabal b/phoityne.cabal
new file mode 100644
--- /dev/null
+++ b/phoityne.cabal
@@ -0,0 +1,65 @@
+name: phoityne
+version: 0.0.1.0
+synopsis: ghci debug viewer with simple editor.
+description: phoityne is a ghci debug viewer with simple editor.
+homepage: under construction
+license: BSD3
+license-file: LICENSE
+author: phoityne_hs
+maintainer: phoityne.hs@gmail.com
+copyright: phoityne_hs
+category: Development
+build-type: Simple
+cabal-version: >=1.10
+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
+ , Phoityne.IO.GUI.GTK.Utility
+ , Phoityne.IO.GUI.GTK.FolderTree
+ , Phoityne.IO.GUI.GTK.SearchResultTable
+ , Phoityne.IO.GUI.GTK.ConsoleView
+ build-depends: base >= 4.7 && < 5
+ , cmdargs
+ , hslogger
+ , ConfigFile
+ , text
+ , bytestring
+ , MissingH
+ , safe
+ , HStringTemplate
+ , gtk3
+ , transformers
+ , containers
+ , mtl
+ , filepath
+ , directory
+ , conduit
+ , conduit-extra
+ , resourcet
+ , process
+ , parsec
+ , Cabal
+ default-language: Haskell2010
+
+