{-# LANGUAGE CPP #-}
module Game.Goatee.Ui.Gtk.MainWindow (
MainWindow,
create,
destroy,
display,
myWindow,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM, forM_, join, liftM)
import Control.Monad.Trans (liftIO)
import qualified Data.Foldable as F
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (intersperse)
import Data.Maybe (catMaybes, fromMaybe)
import Game.Goatee.Ui.Gtk.Common
import qualified Game.Goatee.Ui.Gtk.Actions as Actions
import Game.Goatee.Ui.Gtk.Actions (Actions)
import qualified Game.Goatee.Ui.Gtk.GamePropertiesPanel as GamePropertiesPanel
import Game.Goatee.Ui.Gtk.GamePropertiesPanel (GamePropertiesPanel)
import qualified Game.Goatee.Ui.Gtk.Goban as Goban
import Game.Goatee.Ui.Gtk.Goban (Goban)
import qualified Game.Goatee.Ui.Gtk.InfoLine as InfoLine
import Game.Goatee.Ui.Gtk.InfoLine (InfoLine)
import qualified Game.Goatee.Ui.Gtk.NodePropertiesPanel as NodePropertiesPanel
import Game.Goatee.Ui.Gtk.NodePropertiesPanel (NodePropertiesPanel)
import qualified Game.Goatee.Ui.Gtk.PlayPanel as PlayPanel
import Game.Goatee.Ui.Gtk.PlayPanel (PlayPanel)
import Graphics.UI.Gtk (
Action,
Menu,
Packing (PackGrow, PackNatural),
ToolbarStyle (ToolbarText),
Window,
actionCreateMenuItem, actionCreateToolItem, actionGroupGetAction,
boxPackStart,
containerAdd,
deleteEvent,
eventKeyName, eventModifier,
hPanedNew,
keyPressEvent,
menuBarNew, menuItemNewWithMnemonic, menuItemSetSubmenu, menuNew, menuShellAppend,
notebookAppendPage, notebookNew,
on,
panedPack1, panedPack2, panedSetPosition,
separatorMenuItemNew, separatorToolItemNew,
toAction,
toolbarNew, toolbarSetStyle,
vBoxNew,
widgetDestroy, widgetGrabFocus, widgetShowAll,
windowNew, windowSetDefaultSize, windowSetTitle,
)
import System.Glib (glibToString)
data MainWindow ui = MainWindow
{ myUi :: ui
, myWindow :: Window
, myActions :: Actions ui
, myInfoLine :: InfoLine ui
, myGoban :: Goban ui
, myPlayPanel :: PlayPanel ui
, myGamePropertiesPanel :: GamePropertiesPanel ui
, myNodePropertiesPanel :: NodePropertiesPanel ui
, myDirtyChangedHandler :: IORef (Maybe Registration)
, myFilePathChangedHandler :: IORef (Maybe Registration)
}
create :: UiCtrl go ui => ui -> IO (MainWindow ui)
create ui = do
window <- windowNew
windowSetDefaultSize window 640 480
actions <- Actions.create ui
boardBox <- vBoxNew False 0
containerAdd window boardBox
menuBar <- menuBarNew
boxPackStart boardBox menuBar PackNatural 0
menuFile <- menuItemNewWithMnemonic "_File"
menuFileMenu <- menuNew
menuShellAppend menuBar menuFile
menuItemSetSubmenu menuFile menuFileMenu
menuFileNew <- menuItemNewWithMnemonic "_New file"
menuFileNewMenu <- menuNew
menuItemSetSubmenu menuFileNew menuFileNewMenu
addActionsToMenu menuFileNewMenu actions
[ Actions.myFileNew9Action
, Actions.myFileNew13Action
, Actions.myFileNew19Action
, Actions.myFileNewCustomAction
]
containerAdd menuFileMenu menuFileNew
addActionsToMenu menuFileMenu actions
[ Actions.myFileOpenAction
, Actions.myFileSaveAction
, Actions.myFileSaveAsAction
]
containerAdd menuFileMenu =<< separatorMenuItemNew
addActionsToMenu menuFileMenu actions
[ Actions.myFileCloseAction
, Actions.myFileQuitAction
]
menuEdit <- menuItemNewWithMnemonic "_Edit"
menuEditMenu <- menuNew
menuShellAppend menuBar menuEdit
menuItemSetSubmenu menuEdit menuEditMenu
addActionsToMenu menuEditMenu actions
[ Actions.myEditCutNodeAction
, Actions.myEditCopyNodeAction
, Actions.myEditPasteNodeAction
]
menuGame <- menuItemNewWithMnemonic "_Game"
menuGameMenu <- menuNew
menuShellAppend menuBar menuGame
menuItemSetSubmenu menuGame menuGameMenu
addActionsToMenu menuGameMenu actions
[ Actions.myGamePassAction
]
menuGameVariations <- menuItemNewWithMnemonic "_Variations"
menuGameVariationsMenu <- menuNew
containerAdd menuGameMenu menuGameVariations
menuItemSetSubmenu menuGameVariations menuGameVariationsMenu
containerAdd menuGameVariationsMenu =<<
actionCreateMenuItem (Actions.myGameVariationsChildAction actions)
containerAdd menuGameVariationsMenu =<<
actionCreateMenuItem (Actions.myGameVariationsCurrentAction actions)
containerAdd menuGameVariationsMenu =<< separatorMenuItemNew
containerAdd menuGameVariationsMenu =<<
actionCreateMenuItem (Actions.myGameVariationsBoardMarkupOnAction actions)
containerAdd menuGameVariationsMenu =<<
actionCreateMenuItem (Actions.myGameVariationsBoardMarkupOffAction actions)
menuTool <- menuItemNewWithMnemonic "_Tool"
menuToolMenu <- menuNew
menuShellAppend menuBar menuTool
menuItemSetSubmenu menuTool menuToolMenu
toolbar <- toolbarNew
boxPackStart boardBox toolbar PackNatural 0
toolbarSetStyle toolbar ToolbarText
let addToolSeparator = do
menuSep <- separatorMenuItemNew
toolSep <- separatorToolItemNew
containerAdd menuToolMenu menuSep
containerAdd toolbar toolSep
addTool (AnyTool tool) = do
action <- fromMaybe (error $ "No action for tool with type: " ++ show (toolType tool)) <$>
actionGroupGetAction (Actions.myToolActions actions) (show (toolType tool))
menuItem <- actionCreateMenuItem action
toolItem <- actionCreateToolItem action
containerAdd menuToolMenu menuItem
containerAdd toolbar toolItem
in join $ fmap (sequence_ . intersperse addToolSeparator . catMaybes) $
forM toolOrdering $ \toolGroup -> do
tools <- filter (\(AnyTool tool) -> toolIsImplemented tool) <$>
mapM (findTool ui) toolGroup
return $ if null tools
then Nothing
else Just $ mapM_ addTool tools
menuView <- menuItemNewWithMnemonic "_View"
menuViewMenu <- menuNew
menuShellAppend menuBar menuView
menuItemSetSubmenu menuView menuViewMenu
containerAdd menuViewMenu =<<
actionCreateMenuItem (Actions.myViewHighlightCurrentMovesAction actions)
menuViewStones <- menuItemNewWithMnemonic "_Stones"
menuViewStonesMenu <- menuNew
containerAdd menuViewMenu menuViewStones
menuItemSetSubmenu menuViewStones menuViewStonesMenu
addActionsToMenu menuViewStonesMenu actions
[ toAction . Actions.myViewStonesRegularModeAction
, toAction . Actions.myViewStonesOneColorModeAction
, toAction . Actions.myViewStonesBlindModeAction
]
menuHelp <- menuItemNewWithMnemonic "_Help"
menuHelpMenu <- menuNew
menuShellAppend menuBar menuHelp
menuItemSetSubmenu menuHelp menuHelpMenu
addActionsToMenu menuHelpMenu actions
[ Actions.myHelpKeyBindingsAction
, Actions.myHelpAboutAction
]
infoLine <- InfoLine.create ui
boxPackStart boardBox (InfoLine.myWidget infoLine) PackNatural 0
hPaned <- hPanedNew
boxPackStart boardBox hPaned PackGrow 0
panedSetPosition hPaned 400
goban <- Goban.create ui
panedPack1 hPaned (Goban.myWidget goban) True True
controlsBook <- notebookNew
panedPack2 hPaned controlsBook False True
playPanel <- PlayPanel.create ui
gamePropertiesPanel <- GamePropertiesPanel.create ui
nodePropertiesPanel <- NodePropertiesPanel.create ui
notebookAppendPage controlsBook (PlayPanel.myWidget playPanel) "Play"
notebookAppendPage controlsBook (GamePropertiesPanel.myWidget gamePropertiesPanel) "Game"
notebookAppendPage controlsBook (NodePropertiesPanel.myWidget nodePropertiesPanel) "Properties"
dirtyChangedHandler <- newIORef Nothing
filePathChangedHandler <- newIORef Nothing
let me = MainWindow { myUi = ui
, myWindow = window
, myActions = actions
, myInfoLine = infoLine
, myGoban = goban
, myPlayPanel = playPanel
, myGamePropertiesPanel = gamePropertiesPanel
, myNodePropertiesPanel = nodePropertiesPanel
, myDirtyChangedHandler = dirtyChangedHandler
, myFilePathChangedHandler = filePathChangedHandler
}
initialize me
on window keyPressEvent $ do
key <- glibToString <$> eventKeyName
mods <- eventModifier
let km = (key, mods)
case km of
("Escape", []) -> do
liftIO $ widgetGrabFocus $ Goban.myWidget goban
return True
_ -> return False
on window deleteEvent $ liftIO $ do
fileClose ui
return True
widgetGrabFocus $ Goban.myWidget goban
return me
initialize :: UiCtrl go ui => MainWindow ui -> IO ()
initialize me = do
let ui = myUi me
writeIORef (myDirtyChangedHandler me) =<<
liftM Just (registerDirtyChangedHandler ui "MainWindow" False $ \_ -> updateWindowTitle me)
writeIORef (myFilePathChangedHandler me) =<<
liftM Just (registerFilePathChangedHandler ui "MainWindow" True $ \_ _ -> updateWindowTitle me)
destroy :: UiCtrl go ui => MainWindow ui -> IO ()
destroy me = do
Actions.destroy $ myActions me
InfoLine.destroy $ myInfoLine me
Goban.destroy $ myGoban me
PlayPanel.destroy $ myPlayPanel me
GamePropertiesPanel.destroy $ myGamePropertiesPanel me
NodePropertiesPanel.destroy $ myNodePropertiesPanel me
let ui = myUi me
F.mapM_ (unregisterDirtyChangedHandler ui) =<< readIORef (myDirtyChangedHandler me)
F.mapM_ (unregisterFilePathChangedHandler ui) =<< readIORef (myFilePathChangedHandler me)
widgetDestroy $ myWindow me
display :: MainWindow ui -> IO ()
display = widgetShowAll . myWindow
addActionsToMenu :: Menu -> a -> [a -> Action] -> IO ()
addActionsToMenu menu actions accessors =
forM_ accessors $ \accessor ->
containerAdd menu =<< actionCreateMenuItem (accessor actions)
updateWindowTitle :: UiCtrl go ui => MainWindow ui -> IO ()
updateWindowTitle me = do
let ui = myUi me
fileName <- getFileName ui
dirty <- getDirty ui
let title = fileName ++ " - Goatee"
addDirty = if dirty then ('*':) else id
windowSetTitle (myWindow me) $ addDirty title