{-# 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 , putStrStatusBar -- ToolButton , DebugStartBTClickedEventHandler , DebugStopBTClickedEventHandler , StepOverBTClickedEventHandler , StepInBTClickedEventHandler , BuildBTClickedEventHandler , SaveBTClickedEventHandler , IndentBTClickedEventHandler , UnIndentBTClickedEventHandler , CommentBTClickedEventHandler , UnCommentBTClickedEventHandler , setupToolButton , changeTBsOnGHCiStartting , changeTBsOnGHCiStarted , changeTBsOnGHCiStopped , changeTBsOnDebugStarted , changeTBsOnDebugStopped , changeTBsOnBuildStart , changeTBsOnBuildFinish , isDebugStart , isBuildStart , isGHCiStarted -- 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 StartGHCiBTClickedEventHandler = IO () type StopGHCiBTClickedEventHandler = 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 note <- builderGetObject builder castToNotebook _NAME_CODE_NOTE -- statusBar <- builderGetObject builder castToStatusbar _NAME_STATUS_BAR -- contId <- statusbarGetContextId statusBar "source_file_path" on note switchPage $ switchPageEventHandler note builder return () -- | -- Event Handler -- mainWindowCloseEventHandler :: Window -> MainWindowCloseEventHandler -> EventM EAny Bool mainWindowCloseEventHandler self proc = liftIO $ do proc widgetDestroy self mainQuit return True -- | -- 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) -- | -- -- isGHCiStarted :: Builder -> IO Bool isGHCiStarted builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetGetSensitive bt -- | -- -- isDebugStart :: Builder -> IO Bool isDebugStart builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetGetSensitive bt -- | -- -- isBuildStart :: Builder -> IO Bool isBuildStart builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetGetSensitive bt >>= return . not -- | -- -- switchPageEventHandler :: Notebook -> Builder -> Int -> IO () switchPageEventHandler note builder pageId = do path <- notebookGetNthPage note pageId >>= \case Nothing -> return "[ERROR] texit editor not found." Just child -> notebookGetMenuLabelText note child >>= \case Nothing -> return "[ERROR] texit editor not found." Just a -> return a putStrStatusBar builder path -- | -- -- putStrStatusBar :: Builder -> String -> IO () putStrStatusBar builder msg = do bar <- builderGetObject builder castToStatusbar _NAME_STATUS_BAR contId <- statusbarGetContextId bar _STATUS_BAR_CONTEXT_ID statusbarRemoveAll bar (fromIntegral (toInteger contId)) statusbarPush bar contId msg return () -- |===================================================================== -- 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 -> SaveBTClickedEventHandler -> IndentBTClickedEventHandler -> UnIndentBTClickedEventHandler -> CommentBTClickedEventHandler -> UnCommentBTClickedEventHandler -> StartGHCiBTClickedEventHandler -> StopGHCiBTClickedEventHandler -> IO () setupToolButton builder debugStartEvh debugStopEvh stepOverEvh stepInEvh continueEvh buildEvh saveEvh indentEvh unIndentEvh commentEvh unCommentEvh startGHCi stopGHCi= do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_SAVE onToolButtonClicked bt saveEvh widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD onToolButtonClicked bt buildEvh widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI onToolButtonClicked bt startGHCi widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI onToolButtonClicked bt stopGHCi widgetSetSensitive bt False ------------------------------------ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START onToolButtonClicked bt debugStartEvh widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP onToolButtonClicked bt debugStopEvh widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE onToolButtonClicked bt continueEvh widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER onToolButtonClicked bt stepOverEvh widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN onToolButtonClicked bt stepInEvh widgetSetSensitive bt False ------------------------------------ bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_INDENT onToolButtonClicked bt indentEvh widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNINDENT onToolButtonClicked bt unIndentEvh widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_COMMENT onToolButtonClicked bt commentEvh widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_UNCOMMENT onToolButtonClicked bt unCommentEvh widgetSetSensitive bt True -- | -- -- changeTBsOnGHCiStartting :: Builder -> IO () changeTBsOnGHCiStartting builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False -- | -- -- changeTBsOnGHCiStarted :: Builder -> IO () changeTBsOnGHCiStarted builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False -- | -- -- changeTBsOnGHCiStopped :: Builder -> IO () changeTBsOnGHCiStopped builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False -- | -- -- changeTBsOnBuildStart :: Builder -> IO () changeTBsOnBuildStart builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False -- | -- -- changeTBsOnBuildFinish :: Builder -> IO () changeTBsOnBuildFinish builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False -- | -- -- changeTBsOnDebugStarted :: Builder -> IO () changeTBsOnDebugStarted builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt True -- | -- -- changeTBsOnDebugStopped :: Builder -> IO () changeTBsOnDebugStopped builder = do bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_BUILD widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_START_GHCI widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STOP_GHCI widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_START widgetSetSensitive bt True bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_DEBUG_STOP widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_CONTINUE widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_OVER widgetSetSensitive bt False bt <- builderGetObject builder castToToolButton _NAME_TOOL_BT_STEP_IN widgetSetSensitive bt False