-- 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 .
-- | The main module for the GTK+ UI, used by clients of the UI. Also
-- implements the UI controller.
module Game.Goatee.Ui.Gtk (
startBoard,
startNewBoard,
startFile,
) where
import Control.Concurrent.MVar (MVar, newMVar, takeMVar, readMVar, putMVar, modifyMVar, modifyMVar_)
import Control.Exception (IOException, catch, finally)
import Control.Monad (forM_, join, liftM, unless, when)
import Data.Foldable (foldl')
import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
import Data.Unique (Unique, newUnique)
import Game.Goatee.App
import Game.Goatee.Common
import Game.Goatee.Sgf.Board
import Game.Goatee.Sgf.Renderer
import Game.Goatee.Sgf.Renderer.Tree
import Game.Goatee.Sgf.Tree
import qualified Game.Goatee.Sgf.Monad as Monad
import Game.Goatee.Sgf.Monad (Event, on, childAddedEvent, propertiesModifiedEvent)
import Game.Goatee.Ui.Gtk.Common
import qualified Game.Goatee.Ui.Gtk.MainWindow as MainWindow
import Game.Goatee.Ui.Gtk.MainWindow (MainWindow)
import Graphics.UI.Gtk (
AttrOp ((:=)),
ButtonsType (ButtonsNone, ButtonsOk, ButtonsYesNo),
DialogFlags (DialogDestroyWithParent, DialogModal),
FileChooserAction (FileChooserActionOpen, FileChooserActionSave),
MessageType (MessageError, MessageQuestion),
ResponseId (ResponseCancel, ResponseNo, ResponseOk, ResponseYes),
aboutDialogAuthors, aboutDialogCopyright, aboutDialogLicense, aboutDialogNew,
aboutDialogProgramName, aboutDialogWebsite,
dialogAddButton, dialogRun,
fileChooserAddFilter, fileChooserDialogNew, fileChooserGetFilename,
mainQuit,
messageDialogNew,
stockCancel, stockOpen, stockSave, stockSaveAs,
widgetDestroy, widgetHide,
set,
)
import qualified Paths_goatee_gtk as Paths
import System.Directory (doesFileExist)
-- | A structure for holding global application information about all open
-- boards.
data AppState = AppState { appControllers :: MVar (Map CtrlId UiCtrlImpl)
-- ^ Maps all of the open boards' controllers by
-- their IDs.
}
-- | Creates an 'AppState' that is holding no controllers.
newAppState :: IO AppState
newAppState = do
controllers <- newMVar Map.empty
return AppState { appControllers = controllers }
-- | Registers a 'UiCtrlImpl' with an 'AppState'.
appStateRegister :: AppState -> UiCtrlImpl -> IO ()
appStateRegister appState ui =
modifyMVar_ (appControllers appState) $ return . Map.insert (uiCtrlId ui) ui
-- | Unregisters a 'UiCtrlImpl' from an 'AppState'. If the 'AppState' is left
-- with no controllers, then the GTK+ main loop is shut down and the application
-- exits.
appStateUnregister :: AppState -> UiCtrlImpl -> IO ()
appStateUnregister appState ui = do
ctrls' <- modifyMVar (appControllers appState) $ \ctrls ->
let ctrls' = Map.delete (uiCtrlId ui) ctrls
in return (ctrls', ctrls')
when (Map.null ctrls') mainQuit
data UiHandler = forall handler. UiHandler String (Event UiGoM handler) handler
data DirtyChangedHandlerRecord =
DirtyChangedHandlerRecord { dirtyChangedHandlerOwner :: String
, dirtyChangedHandlerFn :: DirtyChangedHandler
}
data FilePathChangedHandlerRecord =
FilePathChangedHandlerRecord { filePathChangedHandlerOwner :: String
, filePathChangedHandlerFn :: FilePathChangedHandler
}
data ModesChangedHandlerRecord =
ModesChangedHandlerRecord { modesChangedHandlerOwner :: String
, modesChangedHandlerFn :: ModesChangedHandler
}
-- | A unique ID that identifies a 'UiCtrlImpl'.
newtype CtrlId = CtrlId Unique
deriving (Eq, Ord)
-- | Implementation of 'UiCtrl'.
data UiCtrlImpl = UiCtrlImpl { uiCtrlId :: CtrlId
, uiAppState :: AppState
, uiDirty :: IORef Bool
, uiFilePath :: IORef (Maybe FilePath)
, uiModes :: IORef UiModes
, uiCursor :: MVar Cursor
, uiMainWindow :: IORef (Maybe (MainWindow UiCtrlImpl))
-- Go monad action-related properties:
, uiHandlers :: IORef (Map Registration UiHandler)
, uiBaseAction :: IORef (UiGoM ())
-- Ui action-related properties:
, uiDirtyChangedHandlers ::
IORef (Map Registration DirtyChangedHandlerRecord)
, uiFilePathChangedHandlers ::
IORef (Map Registration FilePathChangedHandlerRecord)
, uiModesChangedHandlers ::
IORef (Map Registration ModesChangedHandlerRecord)
}
instance UiCtrl UiCtrlImpl where
readModes = readIORef . uiModes
modifyModes ui f = do
oldModes <- readModes ui
newModes <- f oldModes
unless (newModes == oldModes) $ do
writeIORef (uiModes ui) newModes
fireModesChangedHandlers ui oldModes newModes
runUiGo ui go = do
cursor <- takeMVar (uiCursor ui)
runUiGo' ui go cursor
readCursor = readMVar . uiCursor
isValidMove ui coord = do
cursor <- readMVar $ uiCursor ui
return $ isCurrentValidMove (cursorBoard cursor) coord
playAt ui coord = do
cursor <- takeMVar $ uiCursor ui
if not $ isCurrentValidMove (cursorBoard cursor) coord
then do
dialog <- messageDialogNew Nothing
[DialogModal, DialogDestroyWithParent]
MessageError
ButtonsOk
"Illegal move."
dialogRun dialog
widgetDestroy dialog
putMVar (uiCursor ui) cursor
else case cursorChildPlayingAt coord cursor of
Just child -> runUiGo' ui (Monad.goDown $ cursorChildIndex child) cursor
Nothing ->
let board = cursorBoard cursor
player = boardPlayerTurn board
index = length $ cursorChildren cursor
child = emptyNode { nodeProperties = [colorToMove player coord] }
in runUiGo' ui (Monad.addChild index child >> Monad.goDown index) cursor
goUp ui = runUiGo ui $ do
cursor <- Monad.getCursor
if isNothing $ cursorParent cursor
then return False
else Monad.goUp >> return True
goDown ui index = runUiGo ui $ do
cursor <- Monad.getCursor
if null $ drop index $ cursorChildren cursor
then return False
else Monad.goDown index >> return True
goLeft ui = runUiGo ui $ do
cursor <- Monad.getCursor
case (cursorParent cursor, cursorChildIndex cursor) of
(Nothing, _) -> return False
(Just _, 0) -> return False
(Just _, n) -> do Monad.goUp
Monad.goDown $ n - 1
return True
goRight ui = runUiGo ui $ do
cursor <- Monad.getCursor
case (cursorParent cursor, cursorChildIndex cursor) of
(Nothing, _) -> return False
(Just parent, n) | n == cursorChildCount parent - 1 -> return False
(Just _, n) -> do Monad.goUp
Monad.goDown $ n + 1
return True
register ui caller event handler = do
unique <- newUnique
modifyIORef (uiHandlers ui) $ Map.insert unique $ UiHandler caller event handler
modifyIORef (uiBaseAction ui) (>> on event handler)
return unique
unregister ui unique = do
handlers <- readIORef $ uiHandlers ui
let (handlers', found) = if Map.member unique handlers
then (Map.delete unique handlers, True)
else (handlers, False)
when found $ do
writeIORef (uiHandlers ui) handlers'
rebuildBaseAction ui
return found
registeredHandlers =
liftM (map (\(UiHandler owner event _) -> (owner, show event)) . Map.elems) .
readIORef .
uiHandlers
registerModesChangedHandler ui owner handler = do
unique <- newUnique
modifyIORef (uiModesChangedHandlers ui) $ Map.insert unique
ModesChangedHandlerRecord { modesChangedHandlerOwner = owner
, modesChangedHandlerFn = handler
}
return unique
unregisterModesChangedHandler ui unique = do
handlers <- readIORef $ uiModesChangedHandlers ui
let (handlers', found) = if Map.member unique handlers
then (Map.delete unique handlers, True)
else (handlers, False)
when found $ writeIORef (uiModesChangedHandlers ui) handlers'
return found
registeredModesChangedHandlers =
liftM (map modesChangedHandlerOwner . Map.elems) . readIORef . uiModesChangedHandlers
getMainWindow = fmap MainWindow.myWindow . getMainWindow'
openBoard maybeUi maybePath rootNode = do
ctrlId <- fmap CtrlId newUnique
appState <- maybe newAppState (return . uiAppState) maybeUi
dirty <- newIORef False
filePath <- newIORef maybePath
modesVar <- newIORef defaultUiModes
cursorVar <- newMVar $ rootCursor rootNode
mainWindowRef <- newIORef Nothing
uiHandlers <- newIORef Map.empty
baseAction <- newIORef $ return ()
dirtyChangedHandlers <- newIORef Map.empty
filePathChangedHandlers <- newIORef Map.empty
modesChangedHandlers <- newIORef Map.empty
let ui = UiCtrlImpl { uiCtrlId = ctrlId
, uiAppState = appState
, uiDirty = dirty
, uiFilePath = filePath
, uiModes = modesVar
, uiCursor = cursorVar
, uiMainWindow = mainWindowRef
, uiHandlers = uiHandlers
, uiBaseAction = baseAction
, uiDirtyChangedHandlers = dirtyChangedHandlers
, uiFilePathChangedHandlers = filePathChangedHandlers
, uiModesChangedHandlers = modesChangedHandlers
}
appStateRegister appState ui
rebuildBaseAction ui
mainWindow <- MainWindow.create ui
writeIORef mainWindowRef $ Just mainWindow
MainWindow.display mainWindow
return ui
fileOpen ui = do
dialog <- fileChooserDialogNew (Just "Open a file")
Nothing
FileChooserActionOpen
[(stockCancel, ResponseCancel),
(stockOpen, ResponseOk)]
mapM_ (fileChooserAddFilter dialog) =<< fileFiltersForSgf
response <- dialogRun dialog
widgetHide dialog
finally
(when (response == ResponseOk) $ do
maybePath <- fileChooserGetFilename dialog
when (isJust maybePath) $ do
let path = fromJust maybePath
loadResult <- openFile (Just ui) path
case loadResult of
Left parseError -> do
errorDialog <- messageDialogNew
Nothing
[]
MessageError
ButtonsOk
("Error loading " ++ path ++ ".\n\n" ++ show parseError)
dialogRun errorDialog
widgetDestroy errorDialog
Right _ -> return ())
(widgetDestroy dialog)
fileSave ui = do
cursor <- readCursor ui
maybePath <- getFilePath ui
case maybePath of
Nothing -> fileSaveAs ui
Just path ->
-- TODO Exception handling when the write fails.
-- TODO Don't just write a single tree.
-- TODO Only save when dirty? (Be careful not to break Save As on a non-dirty game.)
case runRender $
renderCollection Collection { collectionTrees = [cursorNode $ cursorRoot cursor] } of
Left message -> do
dialog <- messageDialogNew Nothing
[DialogModal, DialogDestroyWithParent]
MessageError
ButtonsOk
("Error serializing game tree:\n\n" ++ message)
dialogRun dialog
widgetDestroy dialog
return False
Right sgf -> do
writeFile path sgf
setDirty ui False
return True
fileSaveAs ui = do
dialog <- fileChooserDialogNew (Just "Save file as")
Nothing
FileChooserActionSave
[(stockCancel, ResponseCancel),
(stockSave, ResponseOk)]
mapM_ (fileChooserAddFilter dialog) =<< fileFiltersForSgf
response <- dialogRun dialog
finally
(case response of
ResponseOk -> do
maybePath <- fileChooserGetFilename dialog
case maybePath of
Just path -> do
confirm <- confirmSaveIfAlreadyExists path
if confirm
then do setFilePath ui $ Just path
fileSave ui
else return False
_ -> return False
_ -> return False)
(widgetDestroy dialog)
fileClose ui = do
close <- confirmFileClose ui
when close $ closeBoard ui
return close
fileQuit ui = do
ctrls <- fmap Map.elems $ readMVar $ appControllers $ uiAppState ui
okayToClose <- andM $ map confirmFileClose ctrls
when okayToClose $ mapM_ closeBoard ctrls
return okayToClose
helpAbout _ = do
about <- aboutDialogNew
license <- fmap (fromMaybe fallbackLicense) readLicense
set about [ aboutDialogProgramName := applicationName
, aboutDialogCopyright := applicationCopyright
, aboutDialogLicense := Just license
, aboutDialogWebsite := applicationWebsite
, aboutDialogAuthors := applicationAuthors
]
dialogRun about
widgetDestroy about
return ()
getFilePath = readIORef . uiFilePath
setFilePath ui path = do
oldPath <- readIORef $ uiFilePath ui
writeIORef (uiFilePath ui) path
handlers <- readIORef $ uiFilePathChangedHandlers ui
forM_ (Map.elems handlers) $ \record ->
filePathChangedHandlerFn record oldPath path
registerFilePathChangedHandler ui owner fireImmediately handler = do
unique <- newUnique
modifyIORef (uiFilePathChangedHandlers ui) $ Map.insert unique
FilePathChangedHandlerRecord { filePathChangedHandlerOwner = owner
, filePathChangedHandlerFn = handler
}
when fireImmediately $ do
path <- getFilePath ui
handler path path
return unique
unregisterFilePathChangedHandler ui unique = do
handlers <- readIORef $ uiFilePathChangedHandlers ui
let (handlers', found) = if Map.member unique handlers
then (Map.delete unique handlers, True)
else (handlers, False)
when found $ writeIORef (uiFilePathChangedHandlers ui) handlers'
return found
registeredFilePathChangedHandlers =
liftM (map filePathChangedHandlerOwner . Map.elems) . readIORef . uiFilePathChangedHandlers
getDirty = readIORef . uiDirty
setDirty ui newDirty = do
oldDirty <- readIORef $ uiDirty ui
unless (oldDirty == newDirty) $ do
writeIORef (uiDirty ui) newDirty
handlers <- readIORef $ uiDirtyChangedHandlers ui
forM_ (map dirtyChangedHandlerFn $ Map.elems handlers) ($ newDirty)
registerDirtyChangedHandler ui owner fireImmediately handler = do
unique <- newUnique
modifyIORef (uiDirtyChangedHandlers ui) $ Map.insert unique
DirtyChangedHandlerRecord { dirtyChangedHandlerOwner = owner
, dirtyChangedHandlerFn = handler
}
when fireImmediately $ do
dirty <- readIORef $ uiDirty ui
handler dirty
return unique
unregisterDirtyChangedHandler ui unique = do
handlers <- readIORef $ uiDirtyChangedHandlers ui
let (handlers', found) = if Map.member unique handlers
then (Map.delete unique handlers, True)
else (handlers, False)
when found $ writeIORef (uiDirtyChangedHandlers ui) handlers'
return found
registeredDirtyChangedHandlers =
liftM (map dirtyChangedHandlerOwner . Map.elems) . readIORef . uiDirtyChangedHandlers
-- | 'runUiGo' for 'UiCtrlImpl' is implemented by taking the cursor MVar,
-- running a Go action, putting the MVar, then running handlers. Many types of
-- actions the UI wants to perform need to be able to take the cursor
-- themselves, do some logic, then pass it off to run a Go action, re-put, and
-- call handlers. This function is a helper for such UI code.
runUiGo' :: UiCtrlImpl -> UiGoM a -> Cursor -> IO a
runUiGo' ui go cursor = do
baseAction <- readIORef $ uiBaseAction ui
let (value, cursor', handlers) = runUiGoPure (baseAction >> go) cursor
putMVar (uiCursor ui) cursor'
handlers
return value
startBoard :: Node -> IO UiCtrlImpl
startBoard = openBoard Nothing Nothing
startNewBoard :: Maybe (Int, Int) -> IO UiCtrlImpl
startNewBoard = openNewBoard Nothing
startFile :: FilePath -> IO (Either String UiCtrlImpl)
startFile = openFile Nothing
rebuildBaseAction :: UiCtrlImpl -> IO ()
rebuildBaseAction ui =
readIORef (uiHandlers ui) >>= writeIORef (uiBaseAction ui) . buildBaseAction
where buildBaseAction =
foldl' (\io (UiHandler _ event handler) -> io >> on event handler)
commonAction
commonAction = do
-- TODO This really calls for some sort of event hierarchy, so
-- that we can listen for all mutating events here, rather than
-- making it easy to forget to add new events here.
on childAddedEvent $ \_ _ -> setDirtyTrue
on propertiesModifiedEvent $ \_ _ -> setDirtyTrue
setDirtyTrue = afterGo $ setDirty ui True
fireModesChangedHandlers :: UiCtrlImpl -> UiModes -> UiModes -> IO ()
fireModesChangedHandlers ui oldModes newModes = do
handlers <- readIORef $ uiModesChangedHandlers ui
forM_ (Map.elems handlers) $ \handler ->
modesChangedHandlerFn handler oldModes newModes
-- | Retrieves the 'MainWindow' owned by the controller. It is an error to call
-- this before the main window has been set up.
getMainWindow' :: UiCtrlImpl -> IO (MainWindow UiCtrlImpl)
getMainWindow' ui = join $
fmap (maybe (fail "getMainWindow: No window available.") return) $
readIORef $
uiMainWindow ui
-- | If the given file already exists, then the user is shown a dialog box
-- asking whether the file should be overwritten. Returns true if the user says
-- yes, or if the file doesn't exist.
confirmSaveIfAlreadyExists :: FilePath -> IO Bool
confirmSaveIfAlreadyExists path = do
exists <- doesFileExist path
if exists
then do dialog <- messageDialogNew
Nothing
[]
MessageQuestion
ButtonsYesNo
(path ++ " already exists. Overwrite?")
response <- dialogRun dialog
widgetDestroy dialog
return $ response == ResponseYes
else return True
-- | Should be called before destroying the main window. Checks the dirty
-- state of UI; if dirty, then a dialog prompts the user whether the game
-- should be saved before closing, and giving the option to cancel closing.
-- Returns true if the window should be closed.
confirmFileClose :: UiCtrl ui => ui -> IO Bool
confirmFileClose ui = do
dirty <- getDirty ui
if dirty
then do filePath <- getFilePath ui
fileName <- getFileName ui
window <- getMainWindow ui
dialog <- messageDialogNew
(Just window)
[DialogModal, DialogDestroyWithParent]
MessageQuestion
ButtonsNone
(fileName ++ " has unsaved changes. Save before closing?")
dialogAddButton dialog "Close without saving" ResponseNo
dialogAddButton dialog stockCancel ResponseCancel
dialogAddButton dialog (maybe stockSaveAs (const stockSave) filePath) ResponseYes
result <- dialogRun dialog
widgetDestroy dialog
case result of
ResponseYes -> fileSave ui
ResponseNo -> return True
_ -> return False
else return True
-- | Hides and releases the game's 'Game.Goatee.Ui.Gtk.MainWindow', and shuts
-- down the UI controller (in effect closing the game, with no prompting). If
-- this is the last board open, then the application will exit.
closeBoard :: UiCtrlImpl -> IO ()
closeBoard ui = do
MainWindow.destroy =<< getMainWindow' ui
appStateUnregister (uiAppState ui) ui
-- | Attempts to read the project's license file. If successful, the license is
-- returend, otherwise a fallback message is returned instead.
readLicense :: IO (Maybe String)
readLicense = do
path <- Paths.getDataFileName "LICENSE"
fmap Just (readFile path) `Control.Exception.catch` \(_ :: IOException) -> return Nothing
fallbackLicense :: String
fallbackLicense =
"Could not read the license file." ++
"\n" ++
"\nGoatee is free software: you can redistribute it and/or modify" ++
"\nit under the terms of the GNU Affero General Public License as published by" ++
"\nthe Free Software Foundation, either version 3 of the License, or" ++
"\n(at your option) any later version." ++
"\n" ++
"\nGoatee is distributed in the hope that it will be useful," ++
"\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" ++
"\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" ++
"\nGNU Affero General Public License for more details." ++
"\n" ++
"\nYou should have received a copy of the GNU Affero General Public License" ++
"\nalong with Goatee. If not, see ."