-- This file is part of Goatee. -- -- Copyright 2014 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- Goatee is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with Goatee. If not, see . -- | A panel that displays a vertical list of controls for editing a game's -- 'GameInfo'. module Game.Goatee.Ui.Gtk.GamePropertiesPanel ( GamePropertiesPanel, create, destroy, myWidget, ) where import Control.Monad (forM_, void, when) import Data.Maybe (fromMaybe) import Game.Goatee.Sgf.Board import Game.Goatee.Sgf.Monad hiding (on) import Game.Goatee.Sgf.Property import Game.Goatee.Sgf.Tree import Game.Goatee.Sgf.Types import Game.Goatee.Ui.Gtk.Common import Game.Goatee.Ui.Gtk.Latch import Game.Goatee.Ui.Gtk.Utils import Graphics.UI.Gtk ( Entry, Packing (PackGrow, PackNatural), PolicyType (PolicyAutomatic), TextBuffer, TextView, Widget, WrapMode (WrapWord), boxPackStart, bufferChanged, containerAdd, entryNew, entrySetText, get, hSeparatorNew, labelNewWithMnemonic, labelSetMnemonicWidget, on, scrolledWindowNew, scrolledWindowSetPolicy, tableAttachDefaults, tableNew, tableSetRowSpacing, textBufferSetText, textBufferText, textViewGetBuffer, textViewNew, textViewSetWrapMode, toWidget, vBoxNew, ) data GamePropertiesPanel ui = GamePropertiesPanel { myUi :: ui , myRegistrations :: ViewRegistrations , myWidget :: Widget , myBlackName :: Entry , myBlackRank :: Entry , myBlackTeam :: Entry , myWhiteName :: Entry , myWhiteRank :: Entry , myWhiteTeam :: Entry , myComment :: TextView , myCommentLatch :: Latch -- ^ When a 'TextBuffer' is programatically assigned to, -- two change events are fired, one to delete the old -- text and one to insert the new text. We don't want -- to handle the intermediate value by writing it back -- to the model because this triggers dirtyness. So we -- hold this latch on while we are doing a model-to-view -- update in order to avoid this problem. } instance UiCtrl ui => UiView (GamePropertiesPanel ui) ui where viewName = const "GamePropertiesPanel" viewCtrl = myUi viewRegistrations = myRegistrations create :: UiCtrl ui => ui -> IO (GamePropertiesPanel ui) create ui = do let rows = 8 cols = 2 box <- vBoxNew False 0 table <- tableNew rows cols False boxPackStart box table PackNatural 0 let addSeparator row = do sep <- hSeparatorNew tableAttachDefaults table sep 0 cols row (row + 1) tableSetRowSpacing table (row - 1) 6 tableSetRowSpacing table row 6 let blackRow = 0 blackNameLabel <- labelNewWithMnemonic "_Black" blackNameEntry <- entryNew labelSetMnemonicWidget blackNameLabel blackNameEntry tableAttachDefaults table blackNameLabel 0 1 blackRow (blackRow + 1) tableAttachDefaults table blackNameEntry 1 2 blackRow (blackRow + 1) blackRankLabel <- labelNewWithMnemonic "_Rank" blackRankEntry <- entryNew labelSetMnemonicWidget blackRankLabel blackRankEntry tableAttachDefaults table blackRankLabel 0 1 (blackRow + 1) (blackRow + 2) tableAttachDefaults table blackRankEntry 1 2 (blackRow + 1) (blackRow + 2) blackTeamLabel <- labelNewWithMnemonic "T_eam" blackTeamEntry <- entryNew labelSetMnemonicWidget blackTeamLabel blackTeamEntry tableAttachDefaults table blackTeamLabel 0 1 (blackRow + 2) (blackRow + 3) tableAttachDefaults table blackTeamEntry 1 2 (blackRow + 2) (blackRow + 3) addSeparator 3 let whiteRow = 4 whiteNameLabel <- labelNewWithMnemonic "_White" whiteNameEntry <- entryNew labelSetMnemonicWidget whiteNameLabel whiteNameEntry tableAttachDefaults table whiteNameLabel 0 1 whiteRow (whiteRow + 1) tableAttachDefaults table whiteNameEntry 1 2 whiteRow (whiteRow + 1) whiteRankLabel <- labelNewWithMnemonic "Ran_k" whiteRankEntry <- entryNew labelSetMnemonicWidget whiteRankLabel whiteRankEntry tableAttachDefaults table whiteRankLabel 0 1 (whiteRow + 1) (whiteRow + 2) tableAttachDefaults table whiteRankEntry 1 2 (whiteRow + 1) (whiteRow + 2) whiteTeamLabel <- labelNewWithMnemonic "Te_am" whiteTeamEntry <- entryNew labelSetMnemonicWidget whiteTeamLabel whiteTeamEntry tableAttachDefaults table whiteTeamLabel 0 1 (whiteRow + 2) (whiteRow + 3) tableAttachDefaults table whiteTeamEntry 1 2 (whiteRow + 2) (whiteRow + 3) addSeparator 7 comment <- textViewNew commentLatch <- newLatch textViewSetWrapMode comment WrapWord commentScroll <- scrolledWindowNew Nothing Nothing scrolledWindowSetPolicy commentScroll PolicyAutomatic PolicyAutomatic containerAdd commentScroll comment boxPackStart box commentScroll PackGrow 0 registrations <- viewNewRegistrations let me = GamePropertiesPanel { myUi = ui , myRegistrations = registrations , myWidget = toWidget box , myBlackName = blackNameEntry , myBlackRank = blackRankEntry , myBlackTeam = blackTeamEntry , myWhiteName = whiteNameEntry , myWhiteRank = whiteRankEntry , myWhiteTeam = whiteTeamEntry , myComment = comment , myCommentLatch = commentLatch } initialize me return me initialize :: UiCtrl ui => GamePropertiesPanel ui -> IO () initialize me = do let ui = myUi me -- Watch for game info changes. viewRegister me gameInfoChangedEvent $ \_ newInfo -> afterGo $ updateUiGameInfo me newInfo -- Watch for node changes. let onNodeChange = do cursor <- getCursor afterGo $ updateUiNodeInfo me cursor viewRegister me navigationEvent $ const onNodeChange viewRegister me propertiesModifiedEvent $ const $ const onNodeChange updateUi me =<< readCursor ui commentBuffer <- textViewGetBuffer $ myComment me on commentBuffer bufferChanged $ handleCommentBufferChanged me commentBuffer connectEntryToGameInfo ui myBlackName $ \x info -> info { gameInfoBlackName = strToMaybe x } connectEntryToGameInfo ui myBlackRank $ \x info -> info { gameInfoBlackRank = strToMaybe x } connectEntryToGameInfo ui myBlackTeam $ \x info -> info { gameInfoBlackTeamName = strToMaybe x } connectEntryToGameInfo ui myWhiteName $ \x info -> info { gameInfoWhiteName = strToMaybe x } connectEntryToGameInfo ui myWhiteRank $ \x info -> info { gameInfoWhiteRank = strToMaybe x } connectEntryToGameInfo ui myWhiteTeam $ \x info -> info { gameInfoWhiteTeamName = strToMaybe x } where connectEntryToGameInfo ui entryAccessor updater = onEntryChange (entryAccessor me) $ \value -> runUiGo ui $ void $ modifyGameInfo (updater value) strToMaybe str = if null str then Nothing else Just str destroy :: UiCtrl ui => GamePropertiesPanel ui -> IO () destroy = viewUnregisterAll handleCommentBufferChanged :: UiCtrl ui => GamePropertiesPanel ui -> TextBuffer -> IO () handleCommentBufferChanged me commentBuffer = -- Don't push the new comment value back to the model if we're already -- updating the view from the model. whenLatchOff (myCommentLatch me) $ do newComment <- get commentBuffer textBufferText runUiGo (myUi me) $ modifyPropertyString propertyC $ const newComment updateUi :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO () updateUi me cursor = do updateUiGameInfo me $ boardGameInfo $ cursorBoard cursor updateUiNodeInfo me cursor updateUiGameInfo :: GamePropertiesPanel ui -> GameInfo -> IO () updateUiGameInfo me info = forM_ [(gameInfoBlackName, myBlackName), (gameInfoBlackRank, myBlackRank), (gameInfoBlackTeamName, myBlackTeam), (gameInfoWhiteName, myWhiteName), (gameInfoWhiteRank, myWhiteRank), (gameInfoWhiteTeamName, myWhiteTeam)] $ \(getter, entry) -> entrySetText (entry me) $ fromMaybe "" $ getter info updateUiNodeInfo :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO () updateUiNodeInfo me cursor = do let newText = maybe "" fromText $ findPropertyValue propertyC $ cursorNode cursor buf <- textViewGetBuffer $ myComment me oldText <- get buf textBufferText when (oldText /= newText) $ do withLatchOn (myCommentLatch me) $ textBufferSetText buf newText -- It's not necessary to call this handler, but we do for consistency, since -- all other widgets currently behave this way (write back and forth until -- synchronized). handleCommentBufferChanged me buf