{-# LANGUAGE CPP #-}
module Game.Goatee.Ui.Gtk.PlayPanel (
PlayPanel,
create,
destroy,
myWidget,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM, void, when)
import Data.Foldable (forM_, mapM_)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Game.Goatee.Common
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Monad (
AnyEvent (..),
goDown,
goToRoot,
goUp,
modifyPropertyString,
navigationEvent,
propertiesModifiedEvent,
)
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Tree
import Game.Goatee.Lib.Types
import Game.Goatee.Ui.Gtk.Common
import Game.Goatee.Ui.Gtk.Utils
import Graphics.UI.Gtk (
Packing (PackGrow, PackNatural),
PolicyType (PolicyAutomatic),
TextView,
Widget,
WrapMode (WrapWord),
afterShow,
boxPackStart,
buttonActivated, buttonNewWithLabel,
containerAdd,
hBoxNew,
on,
scrolledWindowNew, scrolledWindowSetPolicy,
textViewNew, textViewSetWrapMode,
toWidget,
vBoxNew,
widgetHide, widgetShow,
)
import Prelude hiding (mapM_)
data PlayPanel ui = PlayPanel
{ myUi :: ui
, myState :: ViewState
, myWidget :: Widget
, myComment :: TextView
, myCommentSetter :: String -> IO ()
, myModesChangedHandler :: IORef (Maybe Registration)
}
instance UiCtrl go ui => UiView go ui (PlayPanel ui) where
viewName = const "PlayPanel"
viewCtrl = myUi
viewState = myState
viewUpdate = update
create :: UiCtrl go ui => ui -> IO (PlayPanel ui)
create ui = do
box <- vBoxNew False 0
navBox <- hBoxNew True 0
boxPackStart box navBox PackNatural 0
startButton <- buttonNewWithLabel "<<"
prevButton <- buttonNewWithLabel "<"
nextButton <- buttonNewWithLabel ">"
endButton <- buttonNewWithLabel ">>"
mapM_ (\b -> boxPackStart navBox b PackGrow 0)
[startButton, prevButton, nextButton, endButton]
on startButton buttonActivated $ doUiGo ui goToRoot
on prevButton buttonActivated $ doUiGo ui $ void goUp
on nextButton buttonActivated $ doUiGo ui $ void $ goDown 0
on endButton buttonActivated $ doUiGo ui $ whileM (goDown 0) $ return ()
toolWidgets <- fmap catMaybes $
forM [minBound..] $
fmap (\(AnyTool tool) -> toolPanelWidget tool) .
findTool ui
forM_ (Set.toList $ Set.fromList toolWidgets) $ \widget ->
boxPackStart box widget PackNatural 0
comment <- textViewNew
textViewSetWrapMode comment WrapWord
commentScroll <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy commentScroll PolicyAutomatic PolicyAutomatic
containerAdd commentScroll comment
boxPackStart box commentScroll PackGrow 0
commentSetter <- textViewConfigure comment $ \value ->
doUiGo ui $ modifyPropertyString propertyC $ const value
state <- viewStateNew
modesChangedHandler <- newIORef Nothing
let me = PlayPanel
{ myUi = ui
, myState = state
, myWidget = toWidget box
, myComment = comment
, myCommentSetter = commentSetter
, myModesChangedHandler = modesChangedHandler
}
afterShow (myWidget me) $ updateVisibleToolWidget me
initialize me
return me
initialize :: UiCtrl go ui => PlayPanel ui -> IO ()
initialize me = do
let ui = myUi me
register me
[ AnyEvent navigationEvent
, AnyEvent propertiesModifiedEvent
]
writeIORef (myModesChangedHandler me) =<<
fmap Just (registerModesChangedHandler ui "PlayPanel" $ checkForToolChange me)
viewUpdate me
destroy :: UiCtrl go ui => PlayPanel ui -> IO ()
destroy me = do
let ui = myUi me
mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me)
viewDestroy me
update :: UiCtrl go ui => PlayPanel ui -> IO ()
update me =
readCursor (myUi me) >>=
myCommentSetter me . maybe "" fromText . findPropertyValue propertyC . cursorNode
updateVisibleToolWidget :: UiCtrl go ui => PlayPanel ui -> IO ()
updateVisibleToolWidget me = do
let ui = myUi me
activeToolType <- (\(AnyTool tool) -> toolType tool) <$> readTool ui
forM_ [minBound..] $ \toolType ->
findTool ui toolType >>= \(AnyTool tool) ->
forM_ (toolPanelWidget tool) $ \widget ->
(if toolType == activeToolType then widgetShow else widgetHide) widget
checkForToolChange :: UiCtrl go ui => PlayPanel ui -> UiModes -> UiModes -> IO ()
checkForToolChange me oldModes newModes = do
let ui = myUi me
oldTool = uiToolType oldModes
newTool = uiToolType newModes
when (newTool /= oldTool) $ do
findTool ui oldTool >>= \(AnyTool tool) -> mapM_ widgetHide $ toolPanelWidget tool
findTool ui newTool >>= \(AnyTool tool) -> mapM_ widgetShow $ toolPanelWidget tool