goatee-gtk 0.1.0 → 0.2.0

raw patch · 16 files changed

+2009/−721 lines, 16 filesdep +parsecdep −test-frameworkdep −test-framework-hunitdep ~goateePVP ok

version bump matches the API change (PVP)

Dependencies added: parsec

Dependencies removed: test-framework, test-framework-hunit

Dependency ranges changed: goatee

API changes (from Hackage documentation)

Files

• goatee-gtk.cabal +15/−13
• src-exe/Main.hs +2/−2
• src/Game/Goatee/Ui/Gtk.hs +283/−118
• src/Game/Goatee/Ui/Gtk/Actions.hs +222/−99
• src/Game/Goatee/Ui/Gtk/Common.hs +254/−148
• src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs +363/−155
• src/Game/Goatee/Ui/Gtk/Goban.hs +185/−91
• src/Game/Goatee/Ui/Gtk/InfoLine.hs +35/−32
• src/Game/Goatee/Ui/Gtk/Latch.hs +4/−3
• src/Game/Goatee/Ui/Gtk/MainWindow.hs +107/−45
• src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs +249/−0
• src/Game/Goatee/Ui/Gtk/PlayPanel.hs +131/−0
• src/Game/Goatee/Ui/Gtk/Utils.hs +54/−2
• src/Game/Goatee/Ui/Gtk/Widget.hs +88/−0
• tests/Game/Goatee/Ui/Gtk/LatchTest.hs +7/−9
• tests/Test.hs +10/−4

@@ -1,5 +1,5 @@ name: goatee-gtk-version: 0.1.0+version: 0.2.0 synopsis: A monadic take on a 2,500-year-old board game - GTK+ UI. category: Game license: AGPL-3@@ -14,13 +14,11 @@ build-type: Simple data-files: LICENSE description:-    Goatee is a Go library and game editor, written in Haskell.  It provides a GUI-    for recording, studying, and editing game records.  Underneath this is a-    portable library for manipulating SGF files, to build UIs and tools.-    .-    Goatee, the library and GUI, aims to be full-featured, supporting all of the SGF-    spec and allowing for full customization of the game records you create.-    Currently it is in an alpha stage, supporting basic game viewing and editing.+    Goatee is a Go library and game editor, written in Haskell.  It provides a+    GUI for recording, studying, and editing game records.  Underneath this is a+    portable library for manipulating SGF files to build UIs and tools.  Goatee+    aims to be full-featured by supporting all of the SGF spec and allowing for+    full and easy customization of the game records you create.     .     This package is the GTK+ UI. @@ -36,15 +34,18 @@         directory >= 1.1 && < 1.3,         filepath >= 1.3 && < 1.4,         gtk >= 0.12 && < 0.13,-        goatee >= 0.1 && < 0.2,-        mtl >= 2.1 && < 2.3+        goatee >= 0.2 && < 0.3,+        mtl >= 2.1 && < 2.3,+        parsec >= 3.1 && < 3.2     exposed-modules:         Game.Goatee.Ui.Gtk         Game.Goatee.Ui.Gtk.Latch     extensions:         ExistentialQuantification+        FlexibleContexts         FlexibleInstances         FunctionalDependencies+        GeneralizedNewtypeDeriving         MultiParamTypeClasses         ScopedTypeVariables         ViewPatterns@@ -57,7 +58,10 @@         Game.Goatee.Ui.Gtk.Goban         Game.Goatee.Ui.Gtk.InfoLine         Game.Goatee.Ui.Gtk.MainWindow+        Game.Goatee.Ui.Gtk.NodePropertiesPanel+        Game.Goatee.Ui.Gtk.PlayPanel         Game.Goatee.Ui.Gtk.Utils+        Game.Goatee.Ui.Gtk.Widget         Paths_goatee_gtk  executable goatee-gtk@@ -73,9 +77,7 @@     build-depends:         base >= 4 && < 5,         goatee-gtk,-        HUnit >= 1.2 && < 1.3,-        test-framework >= 0.6 && < 0.9,-        test-framework-hunit >= 0.2 && < 0.4+        HUnit >= 1.2 && < 1.3     ghc-options: -W -fwarn-incomplete-patterns     hs-source-dirs: tests     main-is: Test.hs

@@ -25,8 +25,8 @@ main = do   args <- initGUI   if null args-    then void $ startNewBoard Nothing-    else do result <- startFile $ head args+    then void (startNewBoard Nothing :: IO StdUiCtrlImpl)+    else do result <- startFile $ head args :: IO (Either String StdUiCtrlImpl)             case result of               Left msg -> print msg               _ -> return ()

@@ -18,57 +18,74 @@ -- | The main module for the GTK+ UI, used by clients of the UI.  Also -- implements the UI controller. module Game.Goatee.Ui.Gtk (+  StdUiCtrlImpl,   startBoard,   startNewBoard,   startFile,   ) where +import Control.Applicative ((<$>), Applicative) 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 Control.Monad (forM_, join, liftM, unless, void, when)+import Control.Monad.State (MonadState, State, runState, get, put, modify)+import Data.Char (isSpace)+import qualified Data.Foldable as Foldable 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 qualified Data.Set as Set+import Data.Set (Set) 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.Lib.Board+import Game.Goatee.Lib.Parser+import Game.Goatee.Lib.Renderer+import Game.Goatee.Lib.Renderer.Tree+import Game.Goatee.Lib.Tree+import qualified Game.Goatee.Lib.Monad as Monad+import Game.Goatee.Lib.Monad (+  GoT, MonadGo, runGoT,+  AnyEvent (..), on0, childAddedEvent, childDeletedEvent, 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),+  Clipboard,   DialogFlags (DialogDestroyWithParent, DialogModal),   FileChooserAction (FileChooserActionOpen, FileChooserActionSave),   MessageType (MessageError, MessageQuestion),   ResponseId (ResponseCancel, ResponseNo, ResponseOk, ResponseYes),   aboutDialogAuthors, aboutDialogCopyright, aboutDialogLicense, aboutDialogNew,   aboutDialogProgramName, aboutDialogWebsite,+  clipboardGet, clipboardRequestText, clipboardSetText,   dialogAddButton, dialogRun,   fileChooserAddFilter, fileChooserDialogNew, fileChooserGetFilename,   mainQuit,   messageDialogNew,+  selectionClipboard,   stockCancel, stockOpen, stockSave, stockSaveAs,   widgetDestroy, widgetHide,   set,   ) import qualified Paths_goatee_gtk as Paths import System.Directory (doesFileExist)+import System.IO (hPutStrLn, stderr) +{-# ANN module "HLint: ignore Reduce duplication" #-}+ -- | 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.-                         }+data AppState = AppState+  { appControllers :: MVar (Map CtrlId AnyUiCtrl)+  -- ^ Maps all of the open boards' controllers by their IDs.+  }  -- | Creates an 'AppState' that is holding no controllers. newAppState :: IO AppState@@ -77,77 +94,93 @@   return AppState { appControllers = controllers }  -- | Registers a 'UiCtrlImpl' with an 'AppState'.-appStateRegister :: AppState -> UiCtrlImpl -> IO ()+appStateRegister :: MonadUiGo go => AppState -> UiCtrlImpl go -> IO () appStateRegister appState ui =-  modifyMVar_ (appControllers appState) $ return . Map.insert (uiCtrlId ui) ui+  modifyMVar_ (appControllers appState) $ return . Map.insert (uiCtrlId ui) (AnyUiCtrl 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 -> UiCtrlImpl go -> 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 DirtyChangedHandlerRecord = DirtyChangedHandlerRecord+  { dirtyChangedHandlerOwner :: String+  , dirtyChangedHandlerFn :: DirtyChangedHandler+  } -data FilePathChangedHandlerRecord =-  FilePathChangedHandlerRecord { filePathChangedHandlerOwner :: String-                               , filePathChangedHandlerFn :: FilePathChangedHandler-                               }+data FilePathChangedHandlerRecord = FilePathChangedHandlerRecord+  { filePathChangedHandlerOwner :: String+  , filePathChangedHandlerFn :: FilePathChangedHandler+  } -data ModesChangedHandlerRecord =-  ModesChangedHandlerRecord { modesChangedHandlerOwner :: String-                            , modesChangedHandlerFn :: ModesChangedHandler-                            }+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+-- | The standard instance of 'MonadUiGo', with no frills.+newtype UiGoM a = UiGoM (GoT (State UiGoState) a)+                deriving (Functor, Applicative, Monad, MonadGo, MonadState UiGoState) -                             , uiMainWindow :: IORef (Maybe (MainWindow UiCtrlImpl))+instance MonadUiGo UiGoM where+  runUiGo cursor (UiGoM go) =+    let ((value, cursor'), state) = flip runState initialUiGoState $+                                    runGoT go cursor+    in (value, cursor', state) -                               -- Go monad action-related properties:-                             , uiHandlers :: IORef (Map Registration UiHandler)-                             , uiBaseAction :: IORef (UiGoM ())+  uiGoGetState = get+  uiGoPutState = put+  uiGoModifyState = modify -                               -- Ui action-related properties:-                             , uiDirtyChangedHandlers ::-                               IORef (Map Registration DirtyChangedHandlerRecord)-                             , uiFilePathChangedHandlers ::-                               IORef (Map Registration FilePathChangedHandlerRecord)-                             , uiModesChangedHandlers ::-                               IORef (Map Registration ModesChangedHandlerRecord)-                             }+-- | The standard instance of 'UiCtrl'.  See 'StdUiCtrlImpl'.+data UiCtrlImpl go = UiCtrlImpl+  { uiCtrlId :: CtrlId+  , uiAppState :: AppState+  , uiDirty :: IORef Bool+  , uiFilePath :: IORef (Maybe FilePath)+  , uiModes :: IORef UiModes+  , uiCursor :: MVar Cursor -instance UiCtrl UiCtrlImpl where+  , uiMainWindow :: IORef (Maybe (MainWindow (UiCtrlImpl go)))+  , uiViews :: IORef (Map ViewId AnyView)++    -- Go monad action-related properties:+  , uiGoRegistrationsByView :: IORef (Map AnyView (Set (AnyEvent go)))+  , uiGoRegistrationsByEvent :: IORef (Map (AnyEvent go) (Set AnyView))+  , uiGoRegistrationsAction :: IORef (go ())++    -- Ui action-related properties:+  , uiDirtyChangedHandlers :: IORef (Map Registration DirtyChangedHandlerRecord)+  , uiFilePathChangedHandlers :: IORef (Map Registration FilePathChangedHandlerRecord)+  , uiModesChangedHandlers :: IORef (Map Registration ModesChangedHandlerRecord)+  }++-- | The standard concrete controller type.  Use this type with 'startBoard',+-- etc.+type StdUiCtrlImpl = UiCtrlImpl UiGoM++instance MonadUiGo go => UiCtrl go (UiCtrlImpl go) where   readModes = readIORef . uiModes    modifyModes ui f = do     oldModes <- readModes ui     newModes <- f oldModes-    unless (newModes == oldModes) $ do+    when (newModes /= oldModes) $ do       writeIORef (uiModes ui) newModes       fireModesChangedHandlers ui oldModes newModes -  runUiGo ui go = do+  doUiGo ui go = do     cursor <- takeMVar (uiCursor ui)-    runUiGo' ui go cursor+    doUiGo' ui go cursor    readCursor = readMVar . uiCursor @@ -155,40 +188,44 @@     cursor <- readMVar $ uiCursor ui     return $ isCurrentValidMove (cursorBoard cursor) coord -  playAt ui coord = do+  playAt ui move = do     cursor <- takeMVar $ uiCursor ui-    if not $ isCurrentValidMove (cursorBoard cursor) coord+    let valid = case move of+          Nothing -> True+          Just coord -> isCurrentValidMove (cursorBoard cursor) coord+    if not valid       then do-        dialog <- messageDialogNew Nothing+        putMVar (uiCursor ui) cursor+        mainWindow <- getMainWindow ui+        dialog <- messageDialogNew (Just mainWindow)                                    [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+      else case cursorChildPlayingAt move cursor of+        Just child -> doUiGo' 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+              child = emptyNode { nodeProperties = [moveToProperty player move] }+          in doUiGo' ui (Monad.addChildAt index child >> Monad.goDown index) cursor -  goUp ui = runUiGo ui $ do+  goUp ui = doUiGo ui $ do     cursor <- Monad.getCursor     if isNothing $ cursorParent cursor       then return False       else Monad.goUp >> return True -  goDown ui index = runUiGo ui $ do+  goDown ui index = doUiGo 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+  goLeft ui = doUiGo ui $ do     cursor <- Monad.getCursor     case (cursorParent cursor, cursorChildIndex cursor) of       (Nothing, _) -> return False@@ -197,7 +234,7 @@                         Monad.goDown $ n - 1                         return True -  goRight ui = runUiGo ui $ do+  goRight ui = doUiGo ui $ do     cursor <- Monad.getCursor     case (cursorParent cursor, cursorChildIndex cursor) of       (Nothing, _) -> return False@@ -206,26 +243,77 @@                         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+  register view events = do+    let ui = viewCtrl view+        view' = AnyView view -  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+    -- Ensure that the view is in the controller's id -> view map.+    modifyIORef (uiViews ui) $ \views ->+      if Map.member (viewId view) views+      then views+      else Map.insert (viewId view) view' views +    -- Go ahead and connect the event to the view.+    byView <- readIORef $ uiGoRegistrationsByView ui+    byEvent <- readIORef $ uiGoRegistrationsByEvent ui+    let duplicates = Map.member view' byView+    when duplicates $+      uiLogWarning $ "UiCtrlImpl.register: A " ++ viewName view +++      " view registered multiple times.  Overwriting previous registration(s)."+    writeIORef (uiGoRegistrationsByView ui) $+      Map.alter (Just .+                 (flip .) foldr Set.insert events .+                 fromMaybe Set.empty)+                view'+                byView+    writeIORef (uiGoRegistrationsByEvent ui) $+      foldr (Map.alter $ Just . maybe (Set.singleton view')+                                      (Set.insert view'))+            byEvent+            events+    -- TODO Don't need to fully rebuild the action.  We can append to it.+    rebuildGoRegistrationsAction ui++  unregister view event = do+    let ui = viewCtrl view+        view' = AnyView view+    byView <- readIORef $ uiGoRegistrationsByView ui+    byEvent <- readIORef $ uiGoRegistrationsByEvent ui+    let byView' = Map.update (\events ->+                               let events' = Set.delete event events+                               in if Set.null events' then Nothing else Just events')+                  view'+                  byView+        byEvent' = Map.update (\views ->+                                let views' = Set.delete view' views+                                in if Set.null views' then Nothing else Just views')+                   event+                   byEvent+    writeIORef (uiGoRegistrationsByView ui) byView'+    writeIORef (uiGoRegistrationsByEvent ui) byEvent'++    -- If there are no more events registered for the view, then remove it from+    -- the list of known views.+    when (isNothing $ Map.lookup view' byView') $+      modifyIORef (uiViews ui) $ Map.delete $ viewId view++    rebuildGoRegistrationsAction ui+    return $ maybe False (Set.member event) (Map.lookup view' byView) ||+             maybe False (Set.member view') (Map.lookup event byEvent)++  unregisterAll view =+    let ui = viewCtrl view+    in readIORef (uiGoRegistrationsByView ui) >>=+       Foldable.mapM_ (mapM_ (unregister view) . Set.elems) .+       Map.lookup (AnyView view)+   registeredHandlers =-    liftM (map (\(UiHandler owner event _) -> (owner, show event)) . Map.elems) .+    fmap (concatMap (\(view, events) ->+                      let viewStr = show view+                      in for (Set.elems events) $ \event -> (viewStr, show event)) .+          Map.assocs) .     readIORef .-    uiHandlers+    uiGoRegistrationsByView    registerModesChangedHandler ui owner handler = do     unique <- newUnique@@ -256,8 +344,10 @@     modesVar <- newIORef defaultUiModes     cursorVar <- newMVar $ rootCursor rootNode     mainWindowRef <- newIORef Nothing-    uiHandlers <- newIORef Map.empty-    baseAction <- newIORef $ return ()+    views <- newIORef Map.empty+    goRegistrationsByView <- newIORef Map.empty+    goRegistrationsByEvent <- newIORef Map.empty+    goRegistrationsAction <- newIORef $ return ()     dirtyChangedHandlers <- newIORef Map.empty     filePathChangedHandlers <- newIORef Map.empty     modesChangedHandlers <- newIORef Map.empty@@ -269,15 +359,17 @@                         , uiModes = modesVar                         , uiCursor = cursorVar                         , uiMainWindow = mainWindowRef-                        , uiHandlers = uiHandlers-                        , uiBaseAction = baseAction+                        , uiViews = views+                        , uiGoRegistrationsByView = goRegistrationsByView+                        , uiGoRegistrationsByEvent = goRegistrationsByEvent+                        , uiGoRegistrationsAction = goRegistrationsAction                         , uiDirtyChangedHandlers = dirtyChangedHandlers                         , uiFilePathChangedHandlers = filePathChangedHandlers                         , uiModesChangedHandlers = modesChangedHandlers                         }      appStateRegister appState ui-    rebuildBaseAction ui+    rebuildGoRegistrationsAction ui      mainWindow <- MainWindow.create ui     writeIORef mainWindowRef $ Just mainWindow@@ -362,15 +454,56 @@    fileClose ui = do     close <- confirmFileClose ui-    when close $ closeBoard ui+    when close $ fileCloseSilently ui     return close +  fileCloseSilently ui = do+    MainWindow.destroy =<< getMainWindow' ui+    appStateUnregister (uiAppState ui) ui+   fileQuit ui = do     ctrls <- fmap Map.elems $ readMVar $ appControllers $ uiAppState ui-    okayToClose <- andM $ map confirmFileClose ctrls-    when okayToClose $ mapM_ closeBoard ctrls+    okayToClose <- andM $ for ctrls $ \(AnyUiCtrl ctrl) -> confirmFileClose ctrl+    when okayToClose $ forM_ ctrls $ \(AnyUiCtrl ctrl) -> fileCloseSilently ctrl     return okayToClose +  editCutNode ui = do+    initialCursor <- readCursor ui+    case cursorParent initialCursor of+      Nothing -> uiLogWarning "UiCtrlImpl.editCutNode: Can't cut the root node."+      Just _ -> do+        success <- editCopyNode' ui+        when success $ doUiGo ui $ do+          cursor <- Monad.getCursor+          when (isJust $ cursorParent cursor) $ do+            let index = cursorChildIndex cursor+            Monad.goUp+            Monad.deleteChildAt index+            return ()++  editCopyNode = void . editCopyNode'++  editPasteNode ui = do+    clipboard <- getClipboard+    clipboardRequestText clipboard $ \maybeText -> case maybeText of+      Nothing -> return ()+      Just text -> unless (null text || all isSpace text) $ do+        rootInfo <- gameInfoRootInfo . boardGameInfo . cursorBoard <$> readCursor ui+        case parseSubtree rootInfo text of+          Left error -> do+            let (textBeginning, textRest) = splitAt 500 text+            mainWindow <- getMainWindow ui+            dialog <- messageDialogNew (Just mainWindow)+                      [DialogModal, DialogDestroyWithParent]+                      MessageError+                      ButtonsOk+                      ("Unable to parse the clipboard as an SGF game tree.\n\nError: " +++                       error ++ "\n\nInput:\n" ++ textBeginning +++                       if not $ null textRest then "\n(truncated)" else "")+            dialogRun dialog+            widgetDestroy dialog+          Right node -> doUiGo ui $ Monad.addChild node+   helpAbout _ = do     about <- aboutDialogNew     license <- fmap (fromMaybe fallbackLicense) readLicense@@ -419,7 +552,7 @@    setDirty ui newDirty = do     oldDirty <- readIORef $ uiDirty ui-    unless (oldDirty == newDirty) $ do+    when (newDirty /= oldDirty) $ do       writeIORef (uiDirty ui) newDirty       handlers <- readIORef $ uiDirtyChangedHandlers ui       forM_ (map dirtyChangedHandlerFn $ Map.elems handlers) ($ newDirty)@@ -446,43 +579,53 @@   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+-- | 'doUiGo' for 'UiCtrlImpl' is implemented by taking the cursor MVar, running+-- a Go action, putting the MVar, then running follow-up tasks.  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+-- perform subsequent UI tasks.  This function is a helper for such UI code.+doUiGo' :: MonadUiGo go => UiCtrlImpl go -> go a -> Cursor -> IO a+doUiGo' ui go cursor = do+  goRegistrationsAction <- readIORef $ uiGoRegistrationsAction ui+  let (value, cursor', state) = runUiGo cursor (goRegistrationsAction >> go)+      staleViews = uiGoViewsToUpdate state   putMVar (uiCursor ui) cursor'-  handlers+  when (uiGoMakesDirty state) $ setDirty ui True+  unless (Set.null staleViews) $ do+    viewMap <- readIORef $ uiViews ui+    forM_ (Set.elems staleViews) $ \viewId -> case Map.lookup viewId viewMap of+      Just (AnyView view) -> viewUpdate view+      Nothing -> uiLogWarning "doUiGo': Asked to update an unknown view."   return value -startBoard :: Node -> IO UiCtrlImpl+startBoard :: MonadUiGo go => Node -> IO (UiCtrlImpl go) startBoard = openBoard Nothing Nothing -startNewBoard :: Maybe (Int, Int) -> IO UiCtrlImpl+startNewBoard :: MonadUiGo go => Maybe (Int, Int) -> IO (UiCtrlImpl go) startNewBoard = openNewBoard Nothing -startFile :: FilePath -> IO (Either String UiCtrlImpl)+startFile :: MonadUiGo go => FilePath -> IO (Either String (UiCtrlImpl go)) 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+rebuildGoRegistrationsAction :: MonadUiGo go => UiCtrlImpl go -> IO ()+rebuildGoRegistrationsAction ui =+  readIORef (uiGoRegistrationsByEvent ui) >>=+  writeIORef (uiGoRegistrationsAction ui) . buildAction+  where buildAction =+          foldl' (\m (AnyEvent event, views) ->+                   m >> on0 event (forM_ (Set.elems views) $ \(AnyView view) ->+                                    uiGoUpdateView $ viewId view))+                 commonAction .+          Map.assocs         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+          on0 childAddedEvent uiGoMakeDirty+          on0 childDeletedEvent uiGoMakeDirty+          on0 propertiesModifiedEvent uiGoMakeDirty -fireModesChangedHandlers :: UiCtrlImpl -> UiModes -> UiModes -> IO ()+fireModesChangedHandlers :: UiCtrlImpl go -> UiModes -> UiModes -> IO () fireModesChangedHandlers ui oldModes newModes = do   handlers <- readIORef $ uiModesChangedHandlers ui   forM_ (Map.elems handlers) $ \handler ->@@ -490,7 +633,7 @@  -- | 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' :: UiCtrlImpl go -> IO (MainWindow (UiCtrlImpl go)) getMainWindow' ui = join $                     fmap (maybe (fail "getMainWindow: No window available.") return) $                     readIORef $@@ -518,7 +661,7 @@ -- 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 :: UiCtrl go ui => ui -> IO Bool confirmFileClose ui = do   dirty <- getDirty ui   if dirty@@ -542,14 +685,32 @@               _ -> 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 copy the current node to the clipboard.  Returns true if+-- successful.  If not, this presents a model dialog describing the error, waits+-- for the user to click through, then returns false.+editCopyNode' :: MonadUiGo go => UiCtrlImpl go -> IO Bool+editCopyNode' ui = do+  clipboard <- getClipboard+  cursor <- readCursor ui+  case runRender $ renderGameTree $ cursorNode cursor of+    Right sgf -> do+      clipboardSetText clipboard sgf+      return True+    Left error -> do+      mainWindow <- getMainWindow ui+      dialog <- messageDialogNew (Just mainWindow)+                                 [DialogModal, DialogDestroyWithParent]+                                 MessageError+                                 ButtonsOk+                                 ("Error rendering node for copy:\n\n" ++ error)+      dialogRun dialog+      widgetDestroy dialog+      return False +-- | Returns the clipboard we'll use for explicit cut/copy/paste actions.+getClipboard :: IO Clipboard+getClipboard = clipboardGet selectionClipboard+ -- | 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)@@ -573,3 +734,7 @@   "\n" ++   "\nYou should have received a copy of the GNU Affero General Public License" ++   "\nalong with Goatee.  If not, see <http://www.gnu.org/licenses/>."++-- | Logs a warning to stderr.+uiLogWarning :: String -> IO ()+uiLogWarning msg = hPutStrLn stderr $ applicationName ++ " WARNING: " ++ msg

@@ -29,22 +29,31 @@   myFileSaveAsAction,   myFileCloseAction,   myFileQuitAction,+  myEditCutNodeAction,+  myEditCopyNodeAction,+  myEditPasteNodeAction,+  myGamePassAction,+  myGameVariationsChildAction,+  myGameVariationsCurrentAction,+  myGameVariationsBoardMarkupOnAction,+  myGameVariationsBoardMarkupOffAction,   myToolActions,-  myViewVariationsChildAction,-  myViewVariationsCurrentAction,-  myViewVariationsBoardMarkupOnAction,-  myViewVariationsBoardMarkupOffAction,   myViewHighlightCurrentMovesAction,+  myViewStonesRegularModeAction,+  myViewStonesOneColorModeAction,+  myViewStonesBlindModeAction,   myHelpAboutAction,   ) where  import Control.Applicative ((<$>))-import Control.Monad (void, when)-import Data.Maybe (fromMaybe)+import Control.Monad (unless, void, when)+import Data.Maybe (fromMaybe, isJust) import Game.Goatee.Ui.Gtk.Common-import Game.Goatee.Sgf.Board-import Game.Goatee.Sgf.Monad hiding (on)-import Game.Goatee.Sgf.Types+import Game.Goatee.Ui.Gtk.Utils+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Monad hiding (on)+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Types import Graphics.UI.Gtk (   Action,   ActionGroup,@@ -60,7 +69,7 @@   SpinButtonUpdatePolicy (UpdateIfValid),   ToggleAction,   actionActivate, actionActivated, actionGroupAddActionWithAccel, actionGroupAddRadioActions,-  actionGroupGetAction, actionGroupNew, actionNew, actionToggled,+  actionGroupGetAction, actionGroupNew, actionNew, actionSensitive, actionToggled,   boxPackStart,   dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse,   get,@@ -68,40 +77,50 @@   on,   radioActionChanged, radioActionCurrentValue, radioActionNew, radioActionSetGroup,   set,-  spinButtonGetValueAsInt, spinButtonNewWithRange, spinButtonSetNumeric, spinButtonSetUpdatePolicy,-  spinButtonSetValue, spinButtonSetWrap,+  spinButtonGetValueAsInt, spinButtonNewWithRange, spinButtonSetDigits,+  spinButtonSetNumeric, spinButtonSetUpdatePolicy, spinButtonSetValue, spinButtonSetWrap,   stockCancel,   tableAttachDefaults, tableNew,   toggleActionActive, toggleActionNew,   widgetDestroy, widgetShowAll,+  windowSetTitle,   ) -data Actions ui = Actions { myUi :: ui-                          , myRegistrations :: ViewRegistrations-                          , myFileNew9Action :: Action-                          , myFileNew13Action :: Action-                          , myFileNew19Action :: Action-                          , myFileNewCustomAction :: Action-                          , myFileOpenAction :: Action-                          , myFileSaveAction :: Action-                          , myFileSaveAsAction :: Action-                          , myFileCloseAction :: Action-                          , myFileQuitAction :: Action-                          , myToolActions :: ActionGroup-                          , myViewVariationsChildAction :: RadioAction-                          , myViewVariationsCurrentAction :: RadioAction-                          , myViewVariationsBoardMarkupOnAction :: RadioAction-                          , myViewVariationsBoardMarkupOffAction :: RadioAction-                          , myViewHighlightCurrentMovesAction :: ToggleAction-                          , myHelpAboutAction :: Action-                          }+data Actions ui = Actions+  { myUi :: ui+  , myState :: ViewState+  , myFileNew9Action :: Action+  , myFileNew13Action :: Action+  , myFileNew19Action :: Action+  , myFileNewCustomAction :: Action+  , myFileOpenAction :: Action+  , myFileSaveAction :: Action+  , myFileSaveAsAction :: Action+  , myFileCloseAction :: Action+  , myFileQuitAction :: Action+  , myEditCutNodeAction :: Action+  , myEditCopyNodeAction :: Action+  , myEditPasteNodeAction :: Action+  , myGamePassAction :: Action+  , myGameVariationsChildAction :: RadioAction+  , myGameVariationsCurrentAction :: RadioAction+  , myGameVariationsBoardMarkupOnAction :: RadioAction+  , myGameVariationsBoardMarkupOffAction :: RadioAction+  , myToolActions :: ActionGroup+  , myViewHighlightCurrentMovesAction :: ToggleAction+  , myViewStonesRegularModeAction :: RadioAction+  , myViewStonesOneColorModeAction :: RadioAction+  , myViewStonesBlindModeAction :: RadioAction+  , myHelpAboutAction :: Action+  } -instance UiCtrl ui => UiView (Actions ui) ui where+instance UiCtrl go ui => UiView go ui (Actions ui) where   viewName = const "Actions"   viewCtrl = myUi-  viewRegistrations = myRegistrations+  viewState = myState+  viewUpdate = update -create :: UiCtrl ui => ui -> IO (Actions ui)+create :: UiCtrl go ui => ui -> IO (Actions ui) create ui = do   let tools = enumFrom minBound   modes <- readModes ui@@ -125,23 +144,26 @@   actionGroupAddActionWithAccel fileActions fileNewCustomAction Nothing   on fileNewCustomAction actionActivated $ do     dialog <- dialogNew+    windowSetTitle dialog "New custom board"     upper <- dialogGetUpper dialog-    table <- tableNew 2 2 False+    table <- tableNew 4 2 False     boxPackStart upper table PackGrow 0      -- SGF only supports boards up to 'boardSizeMax', but Goatee works fine with     -- larger boards.  The spinner wants an upper bound, so let's at least set     -- something that isn't too outrageous along a single dimension.-    let arbitraryUpperLimit = 1000+    let arbitraryUpperLimit = 1000 :: Int         makeSpinButton = do           spin <- spinButtonNewWithRange                   (fromIntegral boardSizeMin)                   (fromIntegral arbitraryUpperLimit)                   1+          configureSpinButton spin+          return spin+        configureSpinButton spin = do           spinButtonSetUpdatePolicy spin UpdateIfValid           spinButtonSetNumeric spin True           spinButtonSetWrap spin False-          return spin      widthLabel <- labelNewWithMnemonic "_Width"     widthSpin <- makeSpinButton@@ -155,6 +177,22 @@     tableAttachDefaults table heightLabel 0 1 1 2     tableAttachDefaults table heightSpin 1 2 1 2 +    handicapLabel <- labelNewWithMnemonic "H_andicap"+    handicapSpin <- spinButtonNewWithRange 0 9 1+    labelSetMnemonicWidget handicapLabel handicapSpin+    configureSpinButton handicapSpin+    tableAttachDefaults table handicapLabel 0 1 2 3+    tableAttachDefaults table handicapSpin 1 2 2 3++    komiLabel <- labelNewWithMnemonic "_Komi"+    komiSpin <- spinButtonNewWithRange (-1000) 1000 0.5+    labelSetMnemonicWidget komiLabel komiSpin+    configureSpinButton komiSpin+    spinButtonSetDigits komiSpin 1+    spinButtonSetValue komiSpin 0+    tableAttachDefaults table komiLabel 0 1 3 4+    tableAttachDefaults table komiSpin 1 2 3 4+     dialogAddButton dialog stockCancel ResponseCancel     dialogAddButton dialog "C_reate" ResponseOk     dialogSetDefaultResponse dialog ResponseOk@@ -166,9 +204,25 @@     response <- dialogRun dialog     width <- spinButtonGetValueAsInt widthSpin     height <- spinButtonGetValueAsInt heightSpin+    handicap <- spinButtonGetValueAsInt handicapSpin+    komi <- spinButtonGetValueAsBigfloat komiSpin     widgetDestroy dialog-    when (response == ResponseOk) $-      void $ openNewBoard (Just ui) (Just (width, height))+    when (response == ResponseOk) $ do+      ui' <- openNewBoard (Just ui) (Just (width, height))+      when (komi /= 0) $ doUiGo ui' $ putProperty $ KM komi+      when (handicap > 0) $ do+        -- If the board size + handicap configuration is known, then set up the+        -- board for the handicap, otherwise, leave the user to do it.+        --+        -- TODO If the configuration is unknown and handicap >= 2, then maybe+        -- set HA at least, anyway?+        let stones = fromMaybe [] $ handicapStones width height handicap+        unless (null stones) $ do+          doUiGo ui' $ do+            putProperty $ HA handicap+            putProperty $ AB $ coords stones+            putProperty $ PL White+          setDirty ui' False    fileOpenAction <- actionNew "FileOpen" "_Open file..." Nothing Nothing   actionGroupAddActionWithAccel fileActions fileOpenAction $ Just "<Control>o"@@ -190,63 +244,77 @@   actionGroupAddActionWithAccel fileActions fileQuitAction $ Just "<Control>q"   on fileQuitAction actionActivated $ void $ fileQuit ui -  -- Tool actions.-  toolActions <- actionGroupNew "Tools"-  actionGroupAddRadioActions toolActions-    (flip map tools $ \tool ->-      RadioActionEntry { radioActionName = show tool-                       , radioActionLabel = toolLabel tool-                       , radioActionStockId = Nothing-                       , radioActionAccelerator = Nothing-                       , radioActionTooltip = Nothing-                       , radioActionValue = fromEnum tool-                       })-    (fromEnum initialTool)-    (\radioAction -> setTool ui =<< fmap toEnum (get radioAction radioActionCurrentValue))+  -- Edit actions.+  editCutNodeAction <- actionNew "EditCutNode" "Cut current node" Nothing Nothing+  on editCutNodeAction actionActivated $ editCutNode ui -  -- Variation mode view actions.-  viewVariationsChildAction <- radioActionNew "viewVariationsChild"+  editCopyNodeAction <- actionNew "EditCopyNode" "Copy current node" Nothing Nothing+  on editCopyNodeAction actionActivated $ editCopyNode ui++  editPasteNodeAction <- actionNew "EditPasteNode" "Paste node as child" Nothing Nothing+  on editPasteNodeAction actionActivated $ editPasteNode ui++  -- Game actions.+  gamePassAction <- actionNew "GamePass" "_Pass" Nothing Nothing+  on gamePassAction actionActivated $ playAt ui Nothing++  gameVariationsChildAction <- radioActionNew "gameVariationsChild"                                "_Child variations"                                (Just "Show children node as variations")                                Nothing                                (fromEnum ShowChildVariations)-  viewVariationsCurrentAction <- radioActionNew "viewVariationsCurrent"+  gameVariationsCurrentAction <- radioActionNew "gameVariationsCurrent"                                  "C_urrent variations"                                  (Just "Show variations of the current node")                                  Nothing                                  (fromEnum ShowCurrentVariations)-  radioActionSetGroup viewVariationsChildAction viewVariationsCurrentAction+  radioActionSetGroup gameVariationsChildAction gameVariationsCurrentAction -  viewVariationsBoardMarkupOnAction <- radioActionNew "viewVariationsBoardMarkupOn"+  gameVariationsBoardMarkupOnAction <- radioActionNew "gameVariationsBoardMarkupOn"                                        "_Show on board"                                        (Just "Show move variations on the board")                                        Nothing                                        (fromEnum True)-  viewVariationsBoardMarkupOffAction <- radioActionNew "viewVariationsBoardMarkupOn"+  gameVariationsBoardMarkupOffAction <- radioActionNew "gameVariationsBoardMarkupOn"                                         "_Hide on board"                                         (Just "Hide move variations on the board")                                         Nothing                                         (fromEnum False)-  radioActionSetGroup viewVariationsBoardMarkupOnAction viewVariationsBoardMarkupOffAction+  radioActionSetGroup gameVariationsBoardMarkupOnAction gameVariationsBoardMarkupOffAction    initialVariationMode <-     rootInfoVariationMode . gameInfoRootInfo . boardGameInfo . cursorBoard <$>     readCursor ui-  set viewVariationsChildAction+  set gameVariationsChildAction     [radioActionCurrentValue := fromEnum (variationModeSource initialVariationMode)]-  set viewVariationsBoardMarkupOnAction+  set gameVariationsBoardMarkupOnAction     [radioActionCurrentValue := fromEnum (variationModeBoardMarkup initialVariationMode)]    -- This signal is emitted on every action in a radio group when the active   -- item is changed, so we only need to listen with one action.-  on viewVariationsChildAction radioActionChanged $ \action -> do+  on gameVariationsChildAction radioActionChanged $ \action -> do     value <- toEnum <$> get action radioActionCurrentValue-    runUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeSource = value }+    doUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeSource = value } -  on viewVariationsBoardMarkupOnAction radioActionChanged $ \action -> do+  on gameVariationsBoardMarkupOnAction radioActionChanged $ \action -> do     value <- toEnum <$> get action radioActionCurrentValue-    runUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeBoardMarkup = value }+    doUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeBoardMarkup = value } +  -- Tool actions.+  toolActions <- actionGroupNew "Tools"+  actionGroupAddRadioActions toolActions+    (flip map tools $ \tool ->+      RadioActionEntry { radioActionName = show tool+                       , radioActionLabel = toolLabel tool+                       , radioActionStockId = Nothing+                       , radioActionAccelerator = Nothing+                       , radioActionTooltip = Nothing+                       , radioActionValue = fromEnum tool+                       })+    (fromEnum initialTool)+    (\radioAction -> setTool ui =<< fmap toEnum (get radioAction radioActionCurrentValue))++  -- View actions.   viewHighlightCurrentMovesAction <-     toggleActionNew "ViewHighlightCurrentMoves" "Highlight _current moves" Nothing Nothing   set viewHighlightCurrentMovesAction [toggleActionActive := uiHighlightCurrentMovesMode modes]@@ -254,6 +322,35 @@     active <- get viewHighlightCurrentMovesAction toggleActionActive     modifyModes ui $ \modes -> return modes { uiHighlightCurrentMovesMode = active } +  viewStonesRegularModeAction <-+    radioActionNew "ViewStonesRegularMode"+    "_Regular"+    (Just "Regular Go: Render stones on the board normally.")+    Nothing+    (fromEnum ViewStonesRegularMode)+  viewStonesOneColorModeAction <-+    radioActionNew "ViewStonesOneColorMode"+    "_One-color"+    (Just "One-color Go: Both players use the same color stones.")+    Nothing+    (fromEnum ViewStonesOneColorMode)+  viewStonesBlindModeAction <-+    radioActionNew "ViewStonesBlindMode"+    "_Blind"+    (Just "Blind Go: No stones are visible on the board.")+    Nothing+    (fromEnum ViewStonesBlindMode)++  radioActionSetGroup viewStonesOneColorModeAction viewStonesRegularModeAction+  radioActionSetGroup viewStonesBlindModeAction viewStonesRegularModeAction+  initialViewStonesMode <- uiViewStonesMode <$> readModes ui+  set viewStonesRegularModeAction [radioActionCurrentValue := fromEnum initialViewStonesMode]++  on viewStonesRegularModeAction radioActionChanged $ \action -> do+    value <- toEnum <$> get action radioActionCurrentValue+    modifyModes ui $ \modes -> return modes { uiViewStonesMode = value }++  -- Help actions.   helpAboutAction <- actionNew "HelpAbout" "_About" Nothing Nothing   on helpAboutAction actionActivated $ helpAbout ui @@ -261,46 +358,72 @@     fmap (fromMaybe $ error $ "Could not find the initial tool " ++ show initialTool ++ ".")          (actionGroupGetAction toolActions $ show initialTool) -  registrations <- viewNewRegistrations+  state <- viewStateNew -  let me = Actions { myUi = ui-                   , myRegistrations = registrations-                   , myFileNew9Action = fileNew9Action-                   , myFileNew13Action = fileNew13Action-                   , myFileNew19Action = fileNew19Action-                   , myFileNewCustomAction = fileNewCustomAction-                   , myFileOpenAction = fileOpenAction-                   , myFileSaveAction = fileSaveAction-                   , myFileSaveAsAction = fileSaveAsAction-                   , myFileCloseAction = fileCloseAction-                   , myFileQuitAction = fileQuitAction-                   , myToolActions = toolActions-                   , myViewVariationsChildAction = viewVariationsChildAction-                   , myViewVariationsCurrentAction = viewVariationsCurrentAction-                   , myViewVariationsBoardMarkupOnAction = viewVariationsBoardMarkupOnAction-                   , myViewVariationsBoardMarkupOffAction = viewVariationsBoardMarkupOffAction-                   , myViewHighlightCurrentMovesAction = viewHighlightCurrentMovesAction-                   , myHelpAboutAction = helpAboutAction-                   }+  let me = Actions+        { myUi = ui+        , myState = state+        , myFileNew9Action = fileNew9Action+        , myFileNew13Action = fileNew13Action+        , myFileNew19Action = fileNew19Action+        , myFileNewCustomAction = fileNewCustomAction+        , myFileOpenAction = fileOpenAction+        , myFileSaveAction = fileSaveAction+        , myFileSaveAsAction = fileSaveAsAction+        , myFileCloseAction = fileCloseAction+        , myFileQuitAction = fileQuitAction+        , myEditCutNodeAction = editCutNodeAction+        , myEditCopyNodeAction = editCopyNodeAction+        , myEditPasteNodeAction = editPasteNodeAction+        , myGamePassAction = gamePassAction+        , myGameVariationsChildAction = gameVariationsChildAction+        , myGameVariationsCurrentAction = gameVariationsCurrentAction+        , myGameVariationsBoardMarkupOnAction = gameVariationsBoardMarkupOnAction+        , myGameVariationsBoardMarkupOffAction = gameVariationsBoardMarkupOffAction+        , myToolActions = toolActions+        , myViewHighlightCurrentMovesAction = viewHighlightCurrentMovesAction+        , myViewStonesRegularModeAction = viewStonesRegularModeAction+        , myViewStonesOneColorModeAction = viewStonesOneColorModeAction+        , myViewStonesBlindModeAction = viewStonesBlindModeAction+        , myHelpAboutAction = helpAboutAction+        }    initialize me   return me -initialize :: UiCtrl ui => Actions ui -> IO ()+initialize :: UiCtrl go ui => Actions ui -> IO () initialize me =-  viewRegister me variationModeChangedEvent $ \_ new -> afterGo $ do-    let newSource = fromEnum $ variationModeSource new-        newBoardMarkup = fromEnum $ variationModeBoardMarkup new-        sourceAction = myViewVariationsChildAction me-        boardMarkupAction = myViewVariationsBoardMarkupOnAction me+  register me+    [ AnyEvent navigationEvent+    , AnyEvent variationModeChangedEvent+    ] -    oldSource <- get sourceAction radioActionCurrentValue-    when (newSource /= oldSource) $-      set sourceAction [radioActionCurrentValue := newSource]+destroy :: UiCtrl go ui => Actions ui -> IO ()+destroy = viewDestroy -    oldBoardMarkup <- get boardMarkupAction radioActionCurrentValue-    when (newBoardMarkup /= oldBoardMarkup) $-      set boardMarkupAction [radioActionCurrentValue := newBoardMarkup]+update :: UiCtrl go ui => Actions ui -> IO ()+update me = do+  cursor <- readCursor $ myUi me -destroy :: UiCtrl ui => Actions ui -> IO ()-destroy = viewUnregisterAll+  -- Update the sensitivity of the "Edit > Cut node" action.+  set (myEditCutNodeAction me) [actionSensitive := isJust $ cursorParent cursor]++  updateVariationModeActions me cursor++-- | Updates the selection variation mode radio actions.+updateVariationModeActions :: Actions ui -> Cursor -> IO ()+updateVariationModeActions me cursor = do+  let new = rootInfoVariationMode $ gameInfoRootInfo $ boardGameInfo $+            cursorBoard cursor+      newSource = fromEnum $ variationModeSource new+      newBoardMarkup = fromEnum $ variationModeBoardMarkup new+      sourceAction = myGameVariationsChildAction me+      boardMarkupAction = myGameVariationsBoardMarkupOnAction me++  oldSource <- get sourceAction radioActionCurrentValue+  when (newSource /= oldSource) $+    set sourceAction [radioActionCurrentValue := newSource]++  oldBoardMarkup <- get boardMarkupAction radioActionCurrentValue+  when (newBoardMarkup /= oldBoardMarkup) $+    set boardMarkupAction [radioActionCurrentValue := newBoardMarkup]

@@ -18,11 +18,11 @@ -- | Common dependencies among all GTK+ UI code.  Contains class definitions and -- some common data declarations. module Game.Goatee.Ui.Gtk.Common (+  -- * UI Go monads+  MonadUiGo (..), uiGoUpdateView, uiGoMakeDirty,+  UiGoState (..), initialUiGoState,   -- * UI controllers-  UiGoM,-  afterGo,-  runUiGoPure,-  UiCtrl (..),+  UiCtrl (..), AnyUiCtrl (..),   Registration,   DirtyChangedHandler,   FilePathChangedHandler,@@ -31,131 +31,181 @@   setTool,   -- * UI views   UiView (..),-  ViewRegistrations,-  viewNewRegistrations,-  viewRegister,-  viewUnregisterAll,+  AnyView (..),+  ViewId,+  ViewState,+  viewStateNew,+  viewDestroy,+  viewId,   -- * UI modes   UiModes (..),-  ViewMode (..),+  ViewStonesMode (..),   defaultUiModes,   Tool (..),   initialTool,   toolOrdering,   toolLabel,+  toolIsImplemented,   toolToColor,   fileFiltersForSgf,   ) where  import Control.Applicative ((<$>))-import Control.Monad.Writer (Writer, runWriter, tell)-import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)-import Data.Unique (Unique)-import Game.Goatee.Common (Seq(..))-import Game.Goatee.Sgf.Board-import Game.Goatee.Sgf.Monad-import Game.Goatee.Sgf.Parser-import Game.Goatee.Sgf.Tree-import Game.Goatee.Sgf.Types+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Unique (Unique, newUnique)+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Monad+import Game.Goatee.Lib.Parser+import Game.Goatee.Lib.Tree+import Game.Goatee.Lib.Types import Graphics.UI.Gtk (FileFilter, Window, fileFilterAddPattern, fileFilterNew, fileFilterSetName) import System.FilePath (takeFileName) --- | A Go monad with handlers in the 'IO' monad.-type UiGoM = GoT (Writer (Seq IO))+-- | A class for monads that provide the features required to be used with a+-- 'UiCtrl'.  The type must have a 'MonadGo' instance and also provide access to+-- some internal state, 'UiGoState'.+class MonadGo go => MonadUiGo go where+  -- | Evaluates the Go monad, returning the final value and cursor as well as+  -- the internal 'UiGoState'.+  runUiGo :: Cursor -> go a -> (a, Cursor, UiGoState) --- | Schedules an IO action to run after the currently-executing Go monad--- completes.  The IO action should not attempt to access the cursor, as it may--- not be available; instead it should work within the Go monad for cursor--- manipulation (e.g. 'Game.Goatee.Sgf.Monad.getCursor').-afterGo :: IO () -> UiGoM ()-afterGo = tell . Seq+  -- | Retrieves the current internal state.+  uiGoGetState :: go UiGoState --- | Applies a 'UiGoM' to a 'Cursor' purely, as opposed to 'runUiGo' which works--- with the UI controller's cursor.  Returns a tuple containing the Go action's--- result, the final cursor, and the IO action resulting from all handlers being--- run.-runUiGoPure :: UiGoM a -> Cursor -> (a, Cursor, IO ())-runUiGoPure go cursor =-  let ((value, cursor'), Seq action) = runWriter $ runGoT go cursor-  in (value, cursor', action)+  -- | Assigns to the current internal state.+  uiGoPutState :: UiGoState -> go () --- | A controller for the GTK+ UI.-class UiCtrl a where+  -- | Modifies the current internal state with the given function.+  uiGoModifyState :: (UiGoState -> UiGoState) -> go ()++-- | Forces the view with the given ID to update after the Go action completes.+uiGoUpdateView :: MonadUiGo go => ViewId -> go ()+uiGoUpdateView viewId = uiGoModifyState $ \state ->+  let views = uiGoViewsToUpdate state+  in if Set.member viewId views+     then state+     else state { uiGoViewsToUpdate = Set.insert viewId views }++-- | Forces the UI to become dirty after the Go action completes.  See+-- 'setDirty'.+uiGoMakeDirty :: MonadUiGo go => go ()+uiGoMakeDirty = uiGoModifyState $ \state -> state { uiGoMakesDirty = True }++-- | Internal state held by a type that implements 'MonadUiGo'.+data UiGoState = UiGoState+  { uiGoViewsToUpdate :: Set ViewId+  -- ^ Keeps track of views that need updating after the Go action completes.+  , uiGoMakesDirty :: Bool+    -- ^ Whether the UI should be marked dirty as a result of running the Go+    -- action.+  }++-- | The state with which a UI Go action should start executing.+initialUiGoState :: UiGoState+initialUiGoState = UiGoState+  { uiGoViewsToUpdate = Set.empty+  , uiGoMakesDirty = False+  }++-- | A controller for the GTK+ UI.  A controller corresponds to a single open+-- game.+--+-- The controller is agnostic to the type of Go monad it is used with, as long+-- as it implements the functionality in 'MonadUiGo'.  The monad can have extra+-- functionality, e.g. for testing or debugging.+class MonadUiGo go => UiCtrl go ui | ui -> go where   -- | Reads the current UI modes.-  readModes :: a -> IO UiModes+  readModes :: ui -> IO UiModes    -- | Modifies the controller's modes according to the given action, then fires   -- a mode change event via 'fireViewModesChanged'.-  modifyModes :: a -> (UiModes -> IO UiModes) -> IO ()+  modifyModes :: ui -> (UiModes -> IO UiModes) -> IO ()    -- | Runs a Go monad on the current cursor, updating the cursor and firing   -- handlers as necessary.-  runUiGo :: a -> UiGoM b -> IO b+  doUiGo :: ui -> go a -> IO a    -- | Returns the current cursor.-  readCursor :: a -> IO Cursor+  readCursor :: ui -> IO Cursor    -- | Determines whether it is currently valid to play at the given point.-  isValidMove :: a -> Coord -> IO Bool+  isValidMove :: ui -> Coord -> IO Bool -  -- | Makes the current player place a stone at the given point.-  playAt :: a -> Coord -> IO ()+  -- | Makes the current player place a stone at the given point, or pass in the+  -- case of 'Nothing'.+  playAt :: ui -> Maybe Coord -> IO ()    -- | If possible, takes a step up to the parent of the current node in the   -- game tree.  Returns whether a move was made (i.e. whether the current node   -- is not the root node).-  goUp :: a -> IO Bool+  goUp :: ui -> IO Bool    -- | If possible, takes a step down from the current node to its child at the   -- given index.  Returns whether a move was made (i.e. whether the node had   -- @n+1@ children).-  goDown :: a -> Int -> IO Bool+  goDown :: ui -> Int -> IO Bool    -- | If possible, move to the sibling node immediately to the left of the   -- current one.  Returns whether a move was made (i.e. whether there was a   -- left sibling).-  goLeft :: a -> IO Bool+  goLeft :: ui -> IO Bool    -- | If possible, move to the sibling node immediately to the right of the   -- current one.  Returns whether a move was made (i.e. whether there was a   -- right sibling).-  goRight :: a -> IO Bool+  goRight :: ui -> IO Bool -  -- | Registers a handler for a given 'Event'.  The string is the name of the-  -- caller, used to keep track of what components registered what handlers.-  -- Returns a 'Registration' that can be given to 'unregister' to prevent any-  -- further calls to the handler.-  register :: a -> String -> Event UiGoM handler -> handler -> IO Registration+  -- | Registers a view to update when any of the given 'Event's fires.  The+  -- controller will call 'viewUpdate' after the Go action finishes running.+  --+  -- When the view is destroyed, it must call 'unregister' or 'unregisterAll' to+  -- free the handlers it has installed.  'viewDestroy' calls this, and all+  -- views should call 'viewDestroy', so there is no need to call this manually.+  register :: UiView go ui view => view -> [AnyEvent go] -> IO () -  -- | Unregisters the handler for a 'Registration' that was returned from-  -- 'register'.  Returns true if such a handler was found and removed.-  unregister :: a -> Registration -> IO Bool+  -- | Stops the controller from updating the view when the 'Event' fires.+  -- Returns true if there was a registration that was removed.+  unregister :: UiView go ui view => view -> AnyEvent go -> IO Bool +  -- | Stops the controller from updating the view entirely.+  unregisterAll :: UiView go ui view => view -> IO ()+   -- | Returns the currently registered handlers, as (owner, event name) pairs.-  registeredHandlers :: a -> IO [(String, String)]+  registeredHandlers :: ui -> IO [(String, String)]    -- | Registers a handler that will execute when UI modes change.  The string   -- is the name of the caller, used to keep track of what components registered   -- what handlers.-  registerModesChangedHandler :: a -> String -> ModesChangedHandler -> IO Registration+  registerModesChangedHandler :: ui -> String -> ModesChangedHandler -> IO Registration    -- | Unregisters the modes-changed handler for a 'Registration' that was   -- returned from 'registerModesChangedHandler'.  Returns true if such a   -- handler was found and removed.-  unregisterModesChangedHandler :: a -> Registration -> IO Bool+  unregisterModesChangedHandler :: ui -> Registration -> IO Bool    -- | Returns the owners of the currently registered 'ModesChangedHandler's.-  registeredModesChangedHandlers :: a -> IO [String]+  registeredModesChangedHandlers :: ui -> IO [String]    -- | Returns the 'Window' for the game's 'MainWindow'.-  getMainWindow :: a -> IO Window+  getMainWindow :: ui -> IO Window -  openBoard :: Maybe a -> Maybe FilePath -> Node -> IO a+  openBoard :: Maybe ui -> Maybe FilePath -> Node -> IO ui -  openNewBoard :: Maybe a -> Maybe (Int, Int) -> IO a-  openNewBoard ui = openBoard ui Nothing . rootNode+  openNewBoard :: Maybe ui -> Maybe (Int, Int) -> IO ui+  openNewBoard ui =+    openBoard ui Nothing . -  openFile :: Maybe a -> FilePath -> IO (Either String a)+    -- Show variations of the current move rather than child variations by+    -- default.  The GTK+ UI always renders child variations when told to, even+    -- when there's only a single child, so this puts less noise on the board.+    cursorNode .+    execGo (modifyVariationMode $ const $ VariationMode ShowCurrentVariations True) .+    rootCursor .++    rootNode++  openFile :: Maybe ui -> FilePath -> IO (Either String ui)   openFile ui file = do     result <- parseFile file     case result of@@ -166,53 +216,72 @@    -- | Prompts with an open file dialog for a game to open, then opens the   -- selected game if the user picks one.-  fileOpen :: a -> IO ()+  fileOpen :: ui -> IO ()    -- | Saves the current game to a file.  If the current game is not currently   -- tied to a file, then this will act identically to 'fileSaveAs'.  Returns true   -- iff the game was saved.-  fileSave :: a -> IO Bool+  fileSave :: ui -> IO Bool    -- | Presents a file save dialog for the user to specify a file to write the   -- current game to.  If the user provides a filename, then the game is   -- written.  If the user names an existing file, then another dialog confirms   -- overwriting the existing file.  Returns true iff the user accepted the   -- dialog(s) and the game was saved.-  fileSaveAs :: a -> IO Bool+  fileSaveAs :: ui -> IO Bool    -- | Closes the game and all UI windows, etc. attached to the given controller.   -- If the game is dirty, then a dialog first prompts the user whether to save,   -- throw away changes, or abort the closing.-  fileClose :: a -> IO Bool+  fileClose :: ui -> IO Bool +  -- | Hides and releases the game's UI window, and shut downs the UI controller+  -- (in effect closing the game, with no prompting).  If this is the last board+  -- open, then the application will exit.+  fileCloseSilently :: ui -> IO ()+   -- | Closes all open games and exits the program.  If any games are dirty then   -- we check if the user wants to save them.  If the user clicks cancel at any   -- point then shutdown is cancelled and no games are closed.-  fileQuit :: a -> IO Bool+  fileQuit :: ui -> IO Bool +  -- | Performs a copy a la 'editCopyNode'.  If this copy succeeds, then we+  -- navigate to the parent of the current node, and delete the node we were+  -- just on from the tree.+  editCutNode :: ui -> IO ()++  -- | Copies an SGF representation of the subtree rooted at the current node+  -- onto the system clipboard.  If the node fails to render, then an error+  -- dialog is displayed and the clipboard is left untouched.+  editCopyNode :: ui -> IO ()++  -- | Attempts to parse text on the system clipboard as an SGF subtree and+  -- insert the parsed node below the current node.+  editPasteNode :: ui -> IO ()+   -- | Presents the user with an about dialog that shows general information   -- about the application to the user (authorship, license, etc.).-  helpAbout :: a -> IO ()+  helpAbout :: ui -> IO ()    -- | Returns the path to the file that the UI is currently displaying, or   -- nothing if the UI is displaying an unsaved game.-  getFilePath :: a -> IO (Maybe FilePath)+  getFilePath :: ui -> IO (Maybe FilePath)    -- | Returns the filename (base name, with no directories before it) that is   -- currently open in the UI, or if the UI is showing an unsaved game, then a   -- fallback "untitled" string.  As this may not be a real filename, it should   -- be used for display purposes only, and not for actually writing to.-  getFileName :: a -> IO String+  getFileName :: ui -> IO String   getFileName ui = maybe untitledFileName takeFileName <$> getFilePath ui    -- | Sets the path to the file that the UI is currently displaying.  This   -- changes the value returned by 'getFilePath' but does not do any saving or   -- loading.-  setFilePath :: a -> Maybe FilePath -> IO ()+  setFilePath :: ui -> Maybe FilePath -> IO ()    -- | Registers a handler that will execute when the file path the UI is bound   -- to changes.-  registerFilePathChangedHandler :: a+  registerFilePathChangedHandler :: ui                                  -> String                                     -- ^ The name of the caller, used to track                                     -- what components registered what handlers.@@ -225,21 +294,21 @@   -- | Unregisters the handler for a 'Registration' that was returned from   -- 'registerFilePathChangedHandler'.  Returns true if such a handler was found   -- and removed.-  unregisterFilePathChangedHandler :: a -> Registration -> IO Bool+  unregisterFilePathChangedHandler :: ui -> Registration -> IO Bool    -- | Returns the owners of the currently registered 'FilePathChangedHandler's.-  registeredFilePathChangedHandlers :: a -> IO [String]+  registeredFilePathChangedHandlers :: ui -> IO [String]    -- | Returns whether the UI is dirty, i.e. whether there are unsaved changes   -- to the current game.-  getDirty :: a -> IO Bool+  getDirty :: ui -> IO Bool    -- | Sets the dirty state of the UI.-  setDirty :: a -> Bool -> IO ()+  setDirty :: ui -> Bool -> IO ()    -- | Registers a handler that will execute when the dirty state of the UI   -- changes.-  registerDirtyChangedHandler :: a+  registerDirtyChangedHandler :: ui                               -> String                                  -- ^ The name of the caller, used to track what                                  -- components registered what handlers.@@ -252,13 +321,16 @@   -- | Unregisters the handler for a 'Registration' that was returned from   -- 'registerDirtyChangedHandler'.  Returns true if such a handler was found   -- and removed.-  unregisterDirtyChangedHandler :: a -> Registration -> IO Bool+  unregisterDirtyChangedHandler :: ui -> Registration -> IO Bool    -- | Returns the owners of the currently registered 'DirtyChangedHandler's.-  registeredDirtyChangedHandlers :: a -> IO [String]+  registeredDirtyChangedHandlers :: ui -> IO [String] --- | A key that refers to registration of a handler with a UI controller.  Used--- to unregister handlers.+-- | An existential type for all UI controllers.+data AnyUiCtrl = forall go ui. UiCtrl go ui => AnyUiCtrl ui++-- | A key that refers to registration of a handler with a UI controller, for+-- non-Go-monad events.  Used to unregister handlers. type Registration = Unique  -- | A handler for when the dirty state of the UI changes.  Passed the new dirty@@ -273,94 +345,109 @@ -- the new modes, in that order. type ModesChangedHandler = UiModes -> UiModes -> IO () -modifyModesPure :: UiCtrl ui => ui -> (UiModes -> UiModes) -> IO ()+modifyModesPure :: UiCtrl go ui => ui -> (UiModes -> UiModes) -> IO () modifyModesPure ui f = modifyModes ui (return . f)  -- | Assigns to the current tool within the modes of 'ui' (firing any relevant -- change handlers).-setTool :: UiCtrl ui => ui -> Tool -> IO ()+setTool :: UiCtrl go ui => ui -> Tool -> IO () setTool ui tool = modifyModesPure ui $ \modes -> modes { uiTool = tool }  -- | A UI widget that listens to the state of a 'UiCtrl'.  This class makes it--- easy to register and unregister event handlers with 'viewRegister' and--- 'viewUnregisterAll'.-class UiCtrl ui => UiView view ui | view -> ui where+-- easy to ask to be updated on relevant changes with 'register'.+class UiCtrl go ui => UiView go ui view | view -> ui where   -- | A printable name of the view; usually just the data type name.   viewName :: view -> String    -- | A reference to the view's controller.   viewCtrl :: view -> ui -  -- | An updatable list of registrations for event handlers the view has-  -- registered.-  viewRegistrations :: view -> ViewRegistrations+  -- | Internal housekeeping data for the view.  Create with 'viewStateNew'.  A+  -- 'ViewState' may only be used with a single view.+  viewState :: view -> ViewState -type ViewRegistrations = IORef [Registration]+  -- | Updates the UI state of the view based on the current state of data that+  -- backs it in the model.+  viewUpdate :: view -> IO () --- | Creates a new 'ViewRegistrations'.-viewNewRegistrations :: IO ViewRegistrations-viewNewRegistrations = newIORef []+-- | An existential type over all views.  Provides 'Eq' and 'Ord' instances that+-- use each view's 'ViewId', and a 'Show' instance that returns a view's name.+data AnyView = forall go ui view. UiView go ui view => AnyView view --- | Registers a handler for an event on a view.-viewRegister :: UiView view ui => view -> Event UiGoM handler -> handler -> IO ()-viewRegister view event handler = do-  let ui = viewCtrl view-      name = viewName view-  registration <- register ui name event handler-  modifyIORef (viewRegistrations view) (registration:)+instance Eq AnyView where+  (AnyView v) == (AnyView v') = viewId v == viewId v' --- | Unregisters all event handlers that the view has registered in its--- 'viewRegistrations'.-viewUnregisterAll :: UiView view ui => view -> IO ()-viewUnregisterAll view = do-  let ui = viewCtrl view-      registrations = viewRegistrations view-  readIORef registrations >>= mapM_ (unregister ui)-  writeIORef registrations []+instance Ord AnyView where+  compare (AnyView v) (AnyView v') = compare (viewId v) (viewId v') -data UiModes = UiModes { uiViewMode :: ViewMode-                       , uiViewOneColorModeColor :: Color-                       , uiViewBlindModesAnnouncePlayer :: Bool-                         -- ^ If true, announce the player whose turn it is with-                         -- blindfolds off.  If false, announce the player whose-                         -- turn it is with blindfolds on.-                       , uiHighlightCurrentMovesMode :: Bool-                         -- ^ Whether to draw an indicator on the game board for-                         -- moves on the current node.-                       , uiTool :: Tool-                       } deriving (Eq, Show)+instance Show AnyView where+  show (AnyView v) = viewName v -data ViewMode = ViewRegularMode-              | ViewOneColorMode-              | ViewNothingMode-              deriving (Eq, Show)+-- | A application-wide unique identifier for referring to an instance of a+-- view.+newtype ViewId = ViewId Unique deriving (Eq, Ord) +-- | Internal controller housekeeping data for a view.+data ViewState = ViewState+  { viewId' :: ViewId+  }++-- | Creates a new 'ViewState'.+viewStateNew :: IO ViewState+viewStateNew = ViewState <$> (ViewId <$> newUnique)++-- | Cleans up the internal state of a view, and releases registered Go event+-- handlers for the view.  Views should call this when destroying themselves;+-- this does __not force__ a view to destroy itself.+viewDestroy :: UiView go ui view => view -> IO ()+viewDestroy = unregisterAll++-- | Returns a view's unique ID.+viewId :: UiView go ui view => view -> ViewId+viewId = viewId' . viewState++data UiModes = UiModes+  { uiViewStonesMode :: ViewStonesMode+  , uiViewStonesOneColorModeColor :: Color+  , uiHighlightCurrentMovesMode :: Bool+    -- ^ Whether to draw an indicator on the game board for moves on the current+    -- node.+  , uiTool :: Tool+  } deriving (Eq, Show)++data ViewStonesMode =+  ViewStonesRegularMode+  | ViewStonesOneColorMode+  | ViewStonesBlindMode+  deriving (Bounded, Enum, Eq, Show)+ defaultUiModes :: UiModes-defaultUiModes = UiModes { uiViewMode = ViewRegularMode-                         , uiViewOneColorModeColor = Black-                         , uiViewBlindModesAnnouncePlayer = True-                         , uiHighlightCurrentMovesMode = False-                         , uiTool = ToolPlay-                         }+defaultUiModes = UiModes+  { uiViewStonesMode = ViewStonesRegularMode+  , uiViewStonesOneColorModeColor = Black+  , uiHighlightCurrentMovesMode = True+  , uiTool = ToolPlay+  }  -- | Selectable tools for operating on the board.-data Tool = ToolPlay  -- ^ Game tool.-          | ToolJump  -- ^ Game tool.-          | ToolScore  -- ^ Game tool.-          | ToolBlack  -- ^ Editing tool.-          | ToolWhite  -- ^ Editing tool.-          | ToolErase  -- ^ Editing tool.-          | ToolArrow  -- ^ Markup tool.-          | ToolMarkCircle  -- ^ Markup tool.-          | ToolLabel  -- ^ Markup tool.-          | ToolLine  -- ^ Markup tool.-          | ToolMarkX  -- ^ Markup tool.-          | ToolMarkSelected  -- ^ Markup tool.-          | ToolMarkSquare  -- ^ Markup tool.-          | ToolMarkTriangle  -- ^ Markup tool.-          | ToolVisible  -- ^ Visibility tool.-          | ToolDim  -- ^ Visibility tool.-          deriving (Bounded, Enum, Eq, Show)+data Tool =+  ToolPlay  -- ^ Game tool.+  | ToolJump  -- ^ Game tool.+  | ToolScore  -- ^ Game tool.+  | ToolBlack  -- ^ Editing tool.+  | ToolWhite  -- ^ Editing tool.+  | ToolErase  -- ^ Editing tool.+  | ToolArrow  -- ^ Markup tool.+  | ToolMarkCircle  -- ^ Markup tool.+  | ToolLabel  -- ^ Markup tool.+  | ToolLine  -- ^ Markup tool.+  | ToolMarkX  -- ^ Markup tool.+  | ToolMarkSelected  -- ^ Markup tool.+  | ToolMarkSquare  -- ^ Markup tool.+  | ToolMarkTriangle  -- ^ Markup tool.+  | ToolVisible  -- ^ Visibility tool.+  | ToolDim  -- ^ Visibility tool.+  deriving (Bounded, Enum, Eq, Show)  -- | The tool that should be selected when a board first opens in the UI. initialTool :: Tool@@ -393,6 +480,25 @@   ToolMarkTriangle -> "Mark triangles"   ToolVisible -> "Toggle points visible"   ToolDim -> "Toggle points dimmed"++-- | Returns true if the tool is implemented and should be available in the UI,+-- and false if the tool is not implemented and should not be offered to the+-- user.+--+-- Eventually, this function should be removed.+toolIsImplemented :: Tool -> Bool+toolIsImplemented tool = case tool of+  ToolJump -> False+  ToolScore -> False+  ToolBlack -> False+  ToolWhite -> False+  ToolErase -> False+  ToolArrow -> False+  ToolLabel -> False+  ToolLine -> False+  ToolVisible -> False+  ToolDim -> False+  _ -> True  -- | Converts 'ToolBlack' and 'ToolWhite' into 'Color's.  Does not accept any -- other tools.

@@ -24,212 +24,420 @@   myWidget,   ) where +import Control.Arrow (first) import Control.Monad (forM_, void, when)+import Control.Monad.Trans (liftIO)+import Data.IORef (newIORef, readIORef, writeIORef) 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 qualified Game.Goatee.Common.Bigfloat as BF+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Monad hiding (on)+import Game.Goatee.Lib.Types import Game.Goatee.Ui.Gtk.Common-import Game.Goatee.Ui.Gtk.Latch import Game.Goatee.Ui.Gtk.Utils+import Game.Goatee.Ui.Gtk.Widget import Graphics.UI.Gtk (-  Entry,+  AttachOptions (Expand, Fill),+  AttrOp ((:=)),+  CheckButton,+  Label,   Packing (PackGrow, PackNatural),-  PolicyType (PolicyAutomatic),-  TextBuffer, TextView,+  PolicyType (PolicyAutomatic, PolicyNever),+  TextView,   Widget,-  WrapMode (WrapWord),+  WidgetClass,   boxPackStart,-  bufferChanged,+  checkButtonNewWithLabel,   containerAdd,-  entryNew, entrySetText,+  entryWidthChars,+  focusOutEvent,   get,+  hBoxNew,   hSeparatorNew,-  labelNewWithMnemonic, labelSetMnemonicWidget,+  labelNew, labelSetMnemonicWidget, labelSetText,   on,-  scrolledWindowNew,-  scrolledWindowSetPolicy,-  tableAttachDefaults, tableNew, tableSetRowSpacing,-  textBufferSetText, textBufferText,-  textViewGetBuffer, textViewNew, textViewSetWrapMode,+  scrolledWindowAddWithViewport, scrolledWindowNew, scrolledWindowSetPolicy,+  set,+  spinButtonSetDigits,+  tableAttach, tableAttachDefaults, tableNew, tableSetRowSpacing,+  textViewNew,+  toggleButtonActive, toggled,   toWidget,   vBoxNew,+  widgetSetSensitive, widgetSetSizeRequest,   ) -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.-                      }+-- A getter for 'Stringlike' 'GameInfo' fields.+data InfoGetter = forall a. Stringlike a => InfoGetter (GameInfo -> Maybe a) -instance UiCtrl ui => UiView (GamePropertiesPanel ui) ui where+data GamePropertiesPanel ui = GamePropertiesPanel+  { myUi :: ui+  , myState :: ViewState+  , myWidget :: Widget++    -- Black's info.+  , myBlackNameEntry :: GoateeEntry+  , myBlackRankEntry :: GoateeEntry+  , myBlackTeamEntry :: GoateeEntry++    -- White's info.+  , myWhiteNameEntry :: GoateeEntry+  , myWhiteRankEntry :: GoateeEntry+  , myWhiteTeamEntry :: GoateeEntry++    -- Game rules.+  , myRulesetEntry :: GoateeEntry+  , myMainTimeSpin :: GoateeSpinButton+  , myMainTimeLabel :: Label+  , myOvertimeEntry :: GoateeEntry+  , myGameResultDisplayCheck :: CheckButton+  , myGameResultEntry :: GoateeEntry++    -- Game editors.+  , myGameAnnotatorEntry :: GoateeEntry+  , myGameEntererEntry :: GoateeEntry++    -- Game context.+  , myEventNameEntry :: GoateeEntry+  , myGamePlaceEntry :: GoateeEntry+  , myGameRoundEntry :: GoateeEntry+  , myGameDatesEntry :: GoateeEntry+  , myGameNameEntry :: GoateeEntry+  , myGameSourceEntry :: GoateeEntry+  , myGameCopyrightEntry :: GoateeEntry++    -- Further commentary.+  , myGameOpeningEntry :: GoateeEntry+  , myGameCommentTextView :: TextView+  , myGameCommentTextViewSetter :: String -> IO ()+  }++instance UiCtrl go ui => UiView go ui (GamePropertiesPanel ui) where   viewName = const "GamePropertiesPanel"   viewCtrl = myUi-  viewRegistrations = myRegistrations+  viewState = myState+  viewUpdate = update -create :: UiCtrl ui => ui -> IO (GamePropertiesPanel ui)+create :: UiCtrl go ui => ui -> IO (GamePropertiesPanel ui) create ui = do-  let rows = 8+  let rows = 27       cols = 2+  scroll <- scrolledWindowNew Nothing Nothing   box <- vBoxNew False 0   table <- tableNew rows cols False+  scrolledWindowSetPolicy scroll PolicyNever PolicyAutomatic+  scrolledWindowAddWithViewport scroll box   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+  nextRowRef <- newIORef 0+  let nextRow = do+        row <- readIORef nextRowRef+        writeIORef nextRowRef $ row + 1+        return row+      addSeparator = do+        row <- nextRow+        sep <- hSeparatorNew+        tableAttachDefaults table sep 0 cols row (row + 1)+        tableSetRowSpacing table (row - 1) 6+        tableSetRowSpacing table row 6+      addWidget :: WidgetClass widget => String -> widget -> IO widget+      addWidget labelText widget = do+        row <- nextRow+        label <- labelNew $ Just labelText+        labelSetMnemonicWidget label widget+        tableAttach table label 0 1 row (row + 1)+                    [Fill] [] 0 0+        widgetSetSizeRequest widget 0 (-1)+        tableAttach table widget 1 2 row (row + 1)+                    [Expand, Fill] [] 0 0+        return widget+      addWideWidget :: WidgetClass widget => widget -> IO widget+      addWideWidget widget = do+        row <- nextRow+        widgetSetSizeRequest widget 0 (-1)+        tableAttachDefaults table widget 0 2 row (row + 1)+        return widget+      addEntry :: String -> IO GoateeEntry+      addEntry labelText = do+        entry <- goateeEntryNew+        let widget = goateeEntryWidget entry+        set widget [entryWidthChars := 0]+        addWidget labelText widget+        return entry -  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)+  blackNameEntry <- addEntry "Black"+  blackRankEntry <- addEntry "Rank"+  blackTeamEntry <- addEntry "Team"+  addSeparator+  whiteNameEntry <- addEntry "White"+  whiteRankEntry <- addEntry "Rank"+  whiteTeamEntry <- addEntry "Team"+  addSeparator+  rulesetEntry <- addEntry "Ruleset" -  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)+  mainTimeBox <- hBoxNew True 0+  mainTimeSpin <- goateeSpinButtonNewWithRange 0 3155692600 {- 100 years -} 1+  let mainTimeSpinWidget = goateeSpinButtonWidget mainTimeSpin+  spinButtonSetDigits mainTimeSpinWidget 1+  mainTimeLabel <- labelNew Nothing+  boxPackStart mainTimeBox mainTimeSpinWidget PackGrow 0+  boxPackStart mainTimeBox mainTimeLabel PackNatural 0+  addWidget "Time" mainTimeBox -  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)+  overtimeEntry <- addEntry "Overtime"+  gameResultDisplayCheck <- addWideWidget =<< checkButtonNewWithLabel "Show game result"+  gameResultEntry <- addEntry "Result"+  addSeparator+  gameAnnotatorEntry <- addEntry "Annotator"+  gameEntererEntry <- addEntry "Enterer"+  addSeparator+  eventNameEntry <- addEntry "Event"+  gamePlaceEntry <- addEntry "Place"+  gameRoundEntry <- addEntry "Round"+  gameDatesEntry <- addEntry "Dates"+  gameNameEntry <- addEntry "Name"+  gameSourceEntry <- addEntry "Source"+  gameCopyrightEntry <- addEntry "Copyright"+  addSeparator+  gameOpeningEntry <- addEntry "Opening"+  addWideWidget =<< labelNew (Just "Game comment:") -  addSeparator 3+  gameCommentScroll <- scrolledWindowNew Nothing Nothing+  scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic+  gameCommentTextView <- textViewNew+  -- Set a minimum height on the text view, otherwise it's too short.+  widgetSetSizeRequest gameCommentTextView 0 175+  containerAdd gameCommentScroll gameCommentTextView+  boxPackStart box gameCommentScroll PackNatural 0 -  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)+  gameCommentTextViewSetter <- textViewConfigure gameCommentTextView $ \value ->+    doUiGo ui $ void $ modifyGameInfo $ \info ->+    info { gameInfoGameComment = if null value then Nothing else Just $ stringToSgf value } -  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)+  addedRowCount <- readIORef nextRowRef+  when (addedRowCount /= rows) $ fail $+    "GamePropertiesPanel: Table expected " ++ show rows ++ " rows, got " +++    show addedRowCount ++ "." -  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)+  state <- viewStateNew -  addSeparator 7+  let me = GamePropertiesPanel+        { myUi = ui+        , myState = state+        , myWidget = toWidget scroll -  comment <- textViewNew-  commentLatch <- newLatch-  textViewSetWrapMode comment WrapWord-  commentScroll <- scrolledWindowNew Nothing Nothing-  scrolledWindowSetPolicy commentScroll PolicyAutomatic PolicyAutomatic-  containerAdd commentScroll comment-  boxPackStart box commentScroll PackGrow 0+        , myBlackNameEntry = blackNameEntry+        , myBlackRankEntry = blackRankEntry+        , myBlackTeamEntry = blackTeamEntry -  registrations <- viewNewRegistrations+        , myWhiteNameEntry = whiteNameEntry+        , myWhiteRankEntry = whiteRankEntry+        , myWhiteTeamEntry = whiteTeamEntry -  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-                               }+        , myRulesetEntry = rulesetEntry+        , myMainTimeSpin = mainTimeSpin+        , myMainTimeLabel = mainTimeLabel+        , myOvertimeEntry = overtimeEntry+        , myGameResultDisplayCheck = gameResultDisplayCheck+        , myGameResultEntry = gameResultEntry +        , myGameAnnotatorEntry = gameAnnotatorEntry+        , myGameEntererEntry = gameEntererEntry++        , myEventNameEntry = eventNameEntry+        , myGamePlaceEntry = gamePlaceEntry+        , myGameRoundEntry = gameRoundEntry+        , myGameDatesEntry = gameDatesEntry+        , myGameNameEntry = gameNameEntry+        , myGameSourceEntry = gameSourceEntry+        , myGameCopyrightEntry = gameCopyrightEntry++        , myGameOpeningEntry = gameOpeningEntry+        , myGameCommentTextView = gameCommentTextView+        , myGameCommentTextViewSetter = gameCommentTextViewSetter+        }+   initialize me   return me -initialize :: UiCtrl ui => GamePropertiesPanel ui -> IO ()+initialize :: UiCtrl go ui => GamePropertiesPanel ui -> IO () initialize me = do+  register me [AnyEvent gameInfoChangedEvent]++  viewUpdate me++  connectEntry me (myBlackNameEntry me) gameInfoBlackName $ \x info ->+    info { gameInfoBlackName = x }+  connectEntry me (myBlackRankEntry me) gameInfoBlackRank $ \x info ->+    info { gameInfoBlackRank = x }+  connectEntry me (myBlackTeamEntry me) gameInfoBlackTeamName $ \x info ->+    info { gameInfoBlackTeamName = x }++  connectEntry me (myWhiteNameEntry me) gameInfoWhiteName $ \x info ->+    info { gameInfoWhiteName = x }+  connectEntry me (myWhiteRankEntry me) gameInfoWhiteRank $ \x info ->+    info { gameInfoWhiteRank = x }+  connectEntry me (myWhiteTeamEntry me) gameInfoWhiteTeamName $ \x info ->+    info { gameInfoWhiteTeamName = x }++  connectEntry me (myRulesetEntry me) gameInfoRuleset $ \x info -> info { gameInfoRuleset = x }+  connect me (goateeSpinButtonOnSpinned $ myMainTimeSpin me) $ \x info ->+    info { gameInfoBasicTimeSeconds = if x == 0 then Nothing else Just x }+  connectEntry me (myOvertimeEntry me) gameInfoOvertime $ \x info -> info { gameInfoOvertime = x }+  let gameResultCheck = myGameResultDisplayCheck me+  on gameResultCheck toggled $ viewUpdate me+  connectEntry' me (myGameResultEntry me) (get gameResultCheck toggleButtonActive) gameInfoResult $+    \x info -> info { gameInfoResult = x }++  connectEntry me (myGameAnnotatorEntry me) gameInfoAnnotatorName $ \x info ->+    info { gameInfoAnnotatorName = x }+  connectEntry me (myGameEntererEntry me) gameInfoEntererName $ \x info ->+    info { gameInfoEntererName = x }++  connectEntry me (myEventNameEntry me) gameInfoEvent $ \x info -> info { gameInfoEvent = x }+  connectEntry me (myGamePlaceEntry me) gameInfoPlace $ \x info -> info { gameInfoPlace = x }+  connectEntry me (myGameRoundEntry me) gameInfoRound $ \x info -> info { gameInfoRound = x }+  connectEntry me (myGameDatesEntry me) gameInfoDatesPlayed $ \x info ->+    info { gameInfoDatesPlayed = x }+  connectEntry me (myGameNameEntry me) gameInfoGameName $ \x info -> info { gameInfoGameName = x }+  connectEntry me (myGameSourceEntry me) gameInfoSource $ \x info -> info { gameInfoSource = x }+  connectEntry me (myGameCopyrightEntry me) gameInfoCopyright $ \x info ->+    info { gameInfoCopyright = x }++  connectEntry me (myGameOpeningEntry me) gameInfoOpeningComment $ \x info ->+    info { gameInfoOpeningComment = x }++-- | @connectEntry me entry getter setter@ binds an 'Entry' to a field+-- in the current 'GameInfo' so that changes in one affect the other.+-- Empty strings are coerced to 'Nothing' and vice versa.+--+-- When an 'Entry' is changed, we immediately write the value back to+-- the model: we can't wait until focus out because e.g. opening menus+-- doesn't fire focus-out events.  We also inhibit this widget's model+-- change handler assigning back to the entry, because e.g. we don't+-- want to canonicalize "B+1.0" to "B+1" as soon as it's typed.+-- Instead, we do the model-to-view canonicalizing update on+-- focus-out.+connectEntry :: (UiCtrl go ui, Stringlike a)+             => GamePropertiesPanel ui+             -> GoateeEntry+             -> (GameInfo -> Maybe a)+             -> (Maybe a -> GameInfo -> GameInfo)+             -> IO ()+connectEntry me entry = connectEntry' me entry (return True)++-- | This is like 'connectEntry'.  The additional @IO Bool@ can return false to+-- indicate that a change in the entry should not be written to the model;+-- returning true writes the change.+connectEntry' :: (UiCtrl go ui, Stringlike a)+              => GamePropertiesPanel ui+              -> GoateeEntry+              -> IO Bool+              -> (GameInfo -> Maybe a)+              -> (Maybe a -> GameInfo -> GameInfo)+              -> IO ()+connectEntry' me entry propagateChangesToModel modelGetter modelSetter = do   let ui = myUi me+  goateeEntryOnChange entry $ \value -> do+    propagate <- propagateChangesToModel+    when propagate $ doUiGo ui $ void $ modifyGameInfo $ modelSetter $+      if null value then Nothing else Just $ stringToSgf value+  on (goateeEntryWidget entry) focusOutEvent $ liftIO $ do+    cursor <- readCursor ui+    goateeEntrySetText entry $ maybe "" sgfToString $ modelGetter $+      boardGameInfo $ cursorBoard cursor+    return False+  return () -  -- Watch for game info changes.-  viewRegister me gameInfoChangedEvent $ \_ newInfo ->-    afterGo $ updateUiGameInfo me newInfo+-- | @connect me connectFn setter@ binds a widget to a field in the current+-- 'GameInfo' so that changes in one affect the other.  @connect@ constructs an+-- @a -> IO ()@ handler that takes a value and puts it into the model using+-- @setter@, and immediately gives it to @connectFn@, which is in charge of+-- registering the handler.+connect :: UiCtrl go ui+        => GamePropertiesPanel ui+        -> ((a -> IO ()) -> IO ())+        -> (a -> GameInfo -> GameInfo)+        -> IO ()+connect me connectFn modelSetter =+  let ui = myUi me+  in connectFn $ \newValue -> doUiGo ui $ void $ modifyGameInfo $ modelSetter newValue -  -- Watch for node changes.-  let onNodeChange = do cursor <- getCursor-                        afterGo $ updateUiNodeInfo me cursor-  viewRegister me navigationEvent $ const onNodeChange-  viewRegister me propertiesModifiedEvent $ const $ const onNodeChange+destroy :: UiCtrl go ui => GamePropertiesPanel ui -> IO ()+destroy = viewDestroy -  updateUi me =<< readCursor ui+update :: UiCtrl go ui => GamePropertiesPanel ui -> IO ()+update me = do+  cursor <- readCursor $ myUi me+  let info = boardGameInfo $ cursorBoard cursor+  forM_ [ (InfoGetter gameInfoBlackName, myBlackNameEntry)+        , (InfoGetter gameInfoBlackRank, myBlackRankEntry)+        , (InfoGetter gameInfoBlackTeamName, myBlackTeamEntry) -  commentBuffer <- textViewGetBuffer $ myComment me-  on commentBuffer bufferChanged $ handleCommentBufferChanged me commentBuffer+        , (InfoGetter gameInfoWhiteName, myWhiteNameEntry)+        , (InfoGetter gameInfoWhiteRank, myWhiteRankEntry)+        , (InfoGetter gameInfoWhiteTeamName, myWhiteTeamEntry) -  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 }+        , (InfoGetter gameInfoRuleset, myRulesetEntry)+        , (InfoGetter gameInfoOvertime, myOvertimeEntry) -  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+        , (InfoGetter gameInfoAnnotatorName, myGameAnnotatorEntry)+        , (InfoGetter gameInfoEntererName, myGameEntererEntry) -destroy :: UiCtrl ui => GamePropertiesPanel ui -> IO ()-destroy = viewUnregisterAll+        , (InfoGetter gameInfoEvent, myEventNameEntry)+        , (InfoGetter gameInfoPlace, myGamePlaceEntry)+        , (InfoGetter gameInfoRound, myGameRoundEntry)+        , (InfoGetter gameInfoDatesPlayed, myGameDatesEntry)+        , (InfoGetter gameInfoGameName, myGameNameEntry)+        , (InfoGetter gameInfoSource, myGameSourceEntry)+        , (InfoGetter gameInfoCopyright, myGameCopyrightEntry) -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+        , (InfoGetter gameInfoOpeningComment, myGameOpeningEntry)+        ] $ \(InfoGetter getter, entry) ->+    goateeEntrySetText (entry me) $ extractStringlike $ getter info -updateUi :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO ()-updateUi me cursor = do-  updateUiGameInfo me $ boardGameInfo $ cursorBoard cursor-  updateUiNodeInfo me cursor+  -- Update the "main time" spinner.+  goateeSpinButtonSetValue (myMainTimeSpin me) $ fromMaybe 0 $+    gameInfoBasicTimeSeconds info+  labelSetText (myMainTimeLabel me) $ maybe "" renderSeconds $+    gameInfoBasicTimeSeconds info -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+  -- Update the game result entry.+  let gameResultEntry = myGameResultEntry me+  displayGameResult <- get (myGameResultDisplayCheck me) toggleButtonActive+  widgetSetSensitive (goateeEntryWidget gameResultEntry) displayGameResult+  goateeEntrySetText gameResultEntry $+    if displayGameResult+    then extractStringlike $ gameInfoResult info+    else "(hidden)" -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+  -- Update the game comment TextView.+  myGameCommentTextViewSetter me $ maybe "" fromText $ gameInfoGameComment info++extractStringlike :: Stringlike a => Maybe a -> String+extractStringlike = maybe "" sgfToString++renderSeconds :: BF.Bigfloat -> String+renderSeconds totalSecondsFloat =+  let isNegative = totalSecondsFloat < 0+      (wholeSeconds, fractionalSecondsStr) = first abs $ splitFloat totalSecondsFloat+      (totalMinutes, seconds) = wholeSeconds `divMod` 60+      (hours, minutes) = totalMinutes `divMod` 60+  in (if isNegative then ('-':) else id) $+     (if hours > 0+      then show hours ++ ':' : show2 minutes ++ ':' : show2 seconds+      else show minutes ++ ':' : show2 seconds) +++     fractionalSecondsStr+  where show2 n = if n < 10 then '0' : show n else show n++-- | Returns a pair containing the signed whole part of a 'BF.Bigfloat', plus a+-- string containing a decimal place and everything after it, if the float has a+-- fractional part, otherwise an empty string.+splitFloat :: BF.Bigfloat -> (Integer, String)+splitFloat x =+  let xs = show x+      (addNeg, xs') = case xs of+        '-':xs' -> (('-':), xs')+        _ -> (id, xs)+      (hd, tl) = break (== '.') xs'+  in (read $ addNeg hd, tl)

@@ -24,21 +24,22 @@   ) where  import Control.Applicative ((<$>))-import Control.Monad (liftM, unless, when)+import Control.Monad ((<=<), liftM, unless, when) import qualified Data.Foldable as F import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as Map import Data.Map (Map)-import Data.Maybe (fromJust, isJust)+import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Tree (drawTree, unfoldTree) import Game.Goatee.Common-import Game.Goatee.Sgf.Board hiding (isValidMove)-import Game.Goatee.Sgf.Monad (-  childAddedEvent, modifyMark, navigationEvent, propertiesModifiedEvent,+import Game.Goatee.Lib.Board hiding (isValidMove)+import Game.Goatee.Lib.Monad (+  AnyEvent (..), childAddedEvent, childDeletedEvent, modifyMark, navigationEvent,+  propertiesModifiedEvent,   )-import Game.Goatee.Sgf.Property-import Game.Goatee.Sgf.Tree-import Game.Goatee.Sgf.Types+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Tree+import Game.Goatee.Lib.Types import Game.Goatee.Ui.Gtk.Common import Graphics.Rendering.Cairo (   Antialias (AntialiasDefault, AntialiasNone),@@ -47,6 +48,7 @@   closePath,   deviceToUser,   deviceToUserDistance,+  fill,   fillPreserve,   liftIO,   lineTo,@@ -55,6 +57,7 @@   paintWithAlpha,   popGroupToSource,   pushGroup,+  rectangle,   rotate,   scale,   setAntialias,@@ -62,6 +65,8 @@   setSourceRGB,   stroke,   translate,+  userToDevice,+  userToDeviceDistance,   ) import Graphics.UI.Gtk (   DrawingArea,@@ -70,6 +75,7 @@   Widget,   buttonPressEvent,   drawingAreaNew,+  drawWindowGetPointerPos,   eventCoordinates, eventKeyName, eventModifier,   exposeEvent,   keyPressEvent,@@ -91,7 +97,7 @@ useHorizontalKeyNavigation = True  -- Key handler code below requires that these keys don't use modifiers.-keyNavActions :: UiCtrl a => Map String (a -> IO Bool)+keyNavActions :: UiCtrl go ui => Map String (ui -> IO Bool) keyNavActions =   Map.fromList $   if useHorizontalKeyNavigation@@ -143,6 +149,10 @@ stoneVariationBorderThickness :: Double stoneVariationBorderThickness = 0.02 +-- | The radius of star points.  Percentage of coordinate size, in @[0, 1].+starPointRadius :: Double+starPointRadius = 0.1+ -- | The opacity, in @[0, 1]@, of a stone that should be drawn dimmed because of -- 'DD'. dimmedPointOpacity :: Double@@ -171,31 +181,35 @@ -- | A GTK widget that renders a Go board. -- -- @ui@ should be an instance of 'UiCtrl'.-data Goban ui = Goban { myUi :: ui-                      , myRegistrations :: ViewRegistrations-                      , myWidget :: Widget-                      , myDrawingArea :: DrawingArea-                      , myModesChangedHandler :: IORef (Maybe Registration)-                      }+data Goban ui = Goban+  { myUi :: ui+  , myState :: ViewState+  , myWidget :: Widget+  , myDrawingArea :: DrawingArea+  , myHoverStateRef :: IORef (Maybe HoverState)+    -- ^ A reference to the cached current hover state.  Read with+    -- 'readHoverState' to ensure you get a 'HoverState'.+  , myModesChangedHandler :: IORef (Maybe Registration)+  } -instance UiCtrl ui => UiView (Goban ui) ui where+instance UiCtrl go ui => UiView go ui (Goban ui) where   viewName = const "Goban"   viewCtrl = myUi-  viewRegistrations = myRegistrations+  viewState = myState+  viewUpdate = update  -- | Holds data relating to the state of the mouse hovering over the board.-data HoverState = HoverState { hoverCoord :: Maybe Coord-                               -- ^ The board coordinate corresponding to the-                               -- current mouse position.  Nothing if the mouse-                               -- is not over the board.-                             , hoverIsValidMove :: Bool-                               -- ^ True iff the hovered point is legal to play-                               -- on for the current player.-                             } deriving (Show)+data HoverState = HoverState+  { hoverCoord :: Maybe Coord+    -- ^ The board coordinate corresponding to the current mouse position.+    -- Nothing if the mouse is not over the board.+  , hoverIsValidMove :: Bool+    -- ^ True iff the hovered point is legal to play on for the current player.+  } deriving (Show)  -- | Augments a 'CoordState' with data that is only used for rendering purposes.-data RenderedCoord = RenderedCoord {-  renderedCoordState :: CoordState+data RenderedCoord = RenderedCoord+  { renderedCoordState :: CoordState   , renderedCoordCurrent :: Bool   , renderedCoordVariation :: Maybe Color     -- ^ If a variation move exists at this point, then this will be the color@@ -203,11 +217,11 @@   } deriving (Show)  -- | Creates a 'Goban' for rendering Go boards of the given size.-create :: UiCtrl ui => ui -> IO (Goban ui)+create :: UiCtrl go ui => ui -> IO (Goban ui) create ui = do-  hoverStateRef <- newIORef HoverState { hoverCoord = Nothing-                                       , hoverIsValidMove = False-                                       }+  hoverStateRef <- newIORef $ Just HoverState { hoverCoord = Nothing+                                              , hoverIsValidMove = False+                                              }    drawingArea <- drawingAreaNew   widgetSetCanFocus drawingArea True@@ -215,17 +229,28 @@                                ButtonPressMask,                                PointerMotionMask] +  state <- viewStateNew+  modesChangedHandler <- newIORef Nothing++  let me = Goban { myUi = ui+                 , myState = state+                 , myWidget = toWidget drawingArea+                 , myDrawingArea = drawingArea+                 , myHoverStateRef = hoverStateRef+                 , myModesChangedHandler = modesChangedHandler+                 }+   on drawingArea exposeEvent $ liftIO $ do-    drawBoard ui hoverStateRef drawingArea+    drawBoard me     return True    on drawingArea motionNotifyEvent $ do     mouseCoord <- fmap Just eventCoordinates-    liftIO $ handleMouseMove ui hoverStateRef drawingArea mouseCoord+    liftIO $ handleMouseMove me mouseCoord     return True    on drawingArea leaveNotifyEvent $ do-    liftIO $ handleMouseMove ui hoverStateRef drawingArea Nothing+    liftIO $ handleMouseMove me Nothing     return True    on drawingArea buttonPressEvent $ do@@ -256,61 +281,55 @@              (show $ nodeProperties node, nodeChildren node)            return True)] -  registrations <- viewNewRegistrations-  modesChangedHandler <- newIORef Nothing--  let me = Goban { myUi = ui-                 , myRegistrations = registrations-                 , myWidget = toWidget drawingArea-                 , myDrawingArea = drawingArea-                 , myModesChangedHandler = modesChangedHandler-                 }-   initialize me   return me -initialize :: UiCtrl ui => Goban ui -> IO ()+initialize :: UiCtrl go ui => Goban ui -> IO () initialize me = do   let ui = myUi me-      onChange = afterGo $ update me-  viewRegister me childAddedEvent $ const $ const onChange-  viewRegister me navigationEvent $ const onChange-  viewRegister me propertiesModifiedEvent $ const $ const onChange+  register me+    [ AnyEvent childAddedEvent+    , AnyEvent childDeletedEvent+    , AnyEvent navigationEvent+    , AnyEvent propertiesModifiedEvent+    ]   writeIORef (myModesChangedHandler me) =<<     liftM Just (registerModesChangedHandler ui "Goban" $ \_ _ -> update me)   -- TODO Need to update the hover state's validity on cursor and tool (mode?)   -- changes.-  update me+  --update me -destroy :: UiCtrl ui => Goban ui -> IO ()+destroy :: UiCtrl go ui => Goban ui -> IO () destroy me = do   let ui = myUi me-  viewUnregisterAll me   F.mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me)+  viewDestroy me -update :: UiCtrl ui => Goban ui -> IO ()-update = widgetQueueDraw . myDrawingArea+update :: UiCtrl go ui => Goban ui -> IO ()+update me = do+  invalidateHoverState me+  widgetQueueDraw $ myDrawingArea me  -- | Called when the mouse is moved.  Updates the 'HoverState' according to the -- new mouse location, and redraws the board if necessary.-handleMouseMove :: UiCtrl a-                => a-                -> IORef HoverState-                -> DrawingArea+handleMouseMove :: UiCtrl go ui+                => Goban ui                 -> Maybe (Double, Double)                 -> IO ()-handleMouseMove ui hoverStateRef drawingArea maybeClickCoord = do+handleMouseMove me maybeClickCoord = do+  let ui = myUi me+      drawingArea = myDrawingArea me   maybeXy <- case maybeClickCoord of     Nothing -> return Nothing     Just (mouseX, mouseY) -> do       board <- fmap cursorBoard (readCursor ui)       gtkToBoardCoordinates board drawingArea mouseX mouseY-  updateHoverPosition ui hoverStateRef maybeXy >>= flip when+  updateHoverState me maybeXy >>= flip when     (widgetQueueDraw drawingArea)  -- | Applies the current tool at the given GTK coordinate, if such an action is -- valid.-doToolAtPoint :: UiCtrl ui => ui -> DrawingArea -> (Double, Double) -> IO ()+doToolAtPoint :: UiCtrl go ui => ui -> DrawingArea -> (Double, Double) -> IO () doToolAtPoint ui drawingArea (mouseX, mouseY) = do   cursor <- readCursor ui   let board = cursorBoard cursor@@ -326,28 +345,55 @@       ToolMarkX -> toggleMark ui xy MarkX       ToolPlay -> do         valid <- isValidMove ui xy-        when valid $ playAt ui xy+        when valid $ playAt ui $ Just xy       _ -> return ()  -- TODO Support other tools.-  where toggleMark ui xy mark = runUiGo ui $ modifyMark (toggleMark' mark) xy+  where toggleMark ui xy mark = doUiGo ui $ modifyMark (toggleMark' mark) xy         toggleMark' mark maybeExistingMark = case maybeExistingMark of           Just existingMark | existingMark == mark -> Nothing           _ -> Just mark --- | Updates the hover state for the mouse having moved to the given board--- coordinate.  Returns true if the board coordinate has changed.-updateHoverPosition :: UiCtrl ui => ui -> IORef HoverState -> Maybe Coord -> IO Bool-updateHoverPosition ui hoverStateRef maybeXy = do+-- | Reads the cached hover state, building a new one only if the cache is+-- empty.+readHoverState :: UiCtrl go ui => Goban ui -> IO HoverState+readHoverState me = do+  let ref = myHoverStateRef me+  hoverState <- readIORef ref+  case hoverState of+    Just state -> return state+    Nothing -> do updateHoverStateCurrent me+                  fromMaybe (error "Goban.readHoverState") <$> readIORef ref++-- | Clears the cached hover state.+invalidateHoverState :: Goban ui -> IO ()+invalidateHoverState me = writeIORef (myHoverStateRef me) Nothing++-- | If the mouse has moved or the hover state is nothing, then this updates the+-- hover state based on the mouse being at the given board coordinate (see+-- 'gtkToBoardCoordinates'), and returns true.  Returns false if no update was+-- needed.+updateHoverState :: UiCtrl go ui => Goban ui -> Maybe Coord -> IO Bool+updateHoverState me maybeXy = do+  let ui = myUi me+      hoverStateRef = myHoverStateRef me   hoverState <- readIORef hoverStateRef-  if maybeXy == hoverCoord hoverState-    then return False-    else do valid <- case maybeXy of-              Nothing -> return False-              Just xy -> isValidMove ui xy-            writeIORef hoverStateRef HoverState { hoverCoord = maybeXy-                                                , hoverIsValidMove = valid-                                                }-            return True+  case hoverState of+    Just state | hoverCoord state == maybeXy -> return False+    _ -> do+      valid <- case maybeXy of+        Nothing -> return False+        Just xy -> isValidMove ui xy+      writeIORef hoverStateRef $ Just HoverState { hoverCoord = maybeXy+                                                 , hoverIsValidMove = valid+                                                 }+      return True +-- | Updates the hover state based on the current mouse position.+updateHoverStateCurrent :: UiCtrl go ui => Goban ui -> IO ()+updateHoverStateCurrent me = do+  (_, x, y, _) <- drawWindowGetPointerPos =<< widgetGetDrawWindow (myDrawingArea me)+  updateHoverState me $ Just (x, y)+  return ()+ applyBoardCoordinates :: BoardState -> DrawingArea -> IO (Render ()) applyBoardCoordinates board drawingArea = do   (canvasWidth, canvasHeight) <- return . mapTuple fromIntegral =<< widgetGetSize drawingArea@@ -379,11 +425,13 @@            else Just result  -- | Fully redraws the board based on the current controller and UI state.-drawBoard :: UiCtrl ui => ui -> IORef HoverState -> DrawingArea -> IO ()-drawBoard ui hoverStateRef drawingArea = do+drawBoard :: UiCtrl go ui => Goban ui -> IO ()+drawBoard me = do+  let ui = myUi me+      drawingArea = myDrawingArea me   cursor <- readCursor ui   modes <- readModes ui-  hoverState <- readIORef hoverStateRef+  hoverState <- readHoverState me    let board = cursorBoard cursor       tool = uiTool modes@@ -422,15 +470,35 @@                            y                            grid)               (map (map $ \state -> RenderedCoord state False Nothing) $-               mapBoardCoords maybeAddHover board)+               mapBoardCoords preprocessCoord board)               variations -      maybeAddHover :: Int -> Int -> CoordState -> CoordState-      maybeAddHover y x state = case hoverCoord hoverState of-        Just (hx, hy) | x == hx && y == hy ->-          modifyCoordForHover tool board hoverState state-        _ -> state+      -- | Performs processing at the individual coord level based on UI state.+      preprocessCoord :: Int -> Int -> CoordState -> CoordState+      preprocessCoord y x =+        let maybeAddHover = case hoverCoord hoverState of+              Just (hx, hy) | x == hx && y == hy ->+                modifyCoordForHover tool board hoverState+              _ -> id+            applyStoneViewMode = case uiViewStonesMode modes of+              ViewStonesRegularMode -> id+              ViewStonesOneColorMode -> coerceStone $ uiViewStonesOneColorModeColor modes+              ViewStonesBlindMode -> setStone Nothing+        in applyStoneViewMode . maybeAddHover +      -- | Replaces an existing stone of color opposite to the one given with a+      -- stone of the given color.+      coerceStone :: Color -> CoordState -> CoordState+      coerceStone color state = if coordStone state == Just (cnot color)+                                then state { coordStone = Just color }+                                else state++      -- | Replaces a coordinate's stone.+      setStone :: Maybe Color -> CoordState -> CoordState+      setStone color state = if coordStone state == color+                             then state+                             else state { coordStone = color }+   drawWindow <- widgetGetDrawWindow drawingArea   changeCoords <- applyBoardCoordinates board drawingArea   renderWithDrawable drawWindow $ do@@ -494,9 +562,9 @@       variation = renderedCoordVariation renderedCoord   -- Translate the grid so that we can draw the stone from (0,0) to (1,1).   translate x' y'-  -- Draw the grid, stone (if present), and mark (if present).+  -- Draw the grid, stone or star (if present), and mark (if present).   drawGrid board gridWidth gridBorderWidth x y-  F.mapM_ drawStone $ coordStone coord+  maybe (when (coordStar coord) drawStar) drawStone $ coordStone coord   maybe (return ()) (drawMark $ coordStone coord) $ coordMark coord   case (current, variation) of     -- With @VariationMode ShowChildVariations True@, this is the case of an@@ -556,16 +624,17 @@       gridY0 = if atTop then 0.5 else 0       gridX1 = if atRight then 0.5 else 1       gridY1 = if atBottom then 0.5 else 1+  (cx, cy) <- roundToPixels 0.5 0.5   -- Temporarily disable antialiasing.  We want grid lines to be sharp.   setAntialias AntialiasNone   setSourceRGB 0 0 0   setLineWidth $ if atTop || atBottom then gridBorderWidth else gridWidth-  moveTo gridX0 0.5-  lineTo gridX1 0.5+  moveTo gridX0 cy+  lineTo gridX1 cy   stroke   setLineWidth $ if atLeft || atRight then gridBorderWidth else gridWidth-  moveTo 0.5 gridY0-  lineTo 0.5 gridY1+  moveTo cx gridY0+  lineTo cx gridY1   stroke   setAntialias AntialiasDefault @@ -579,6 +648,26 @@   setRgb $ stoneBorderColor color   stroke +-- | Draws a dot to indicate that the current point is a star point.+drawStar :: Render ()+drawStar = do+  setSourceRGB 0 0 0+  -- This seems to be a decent point to transition from an antialiased star to+  -- an aliased star (well, box), balancing transitioning too early (having a+  -- jump in size) with too late (and having ugly antialiased bouncing star+  -- points for a range).+  let minRadiusOnScreen = 1.8+  (radiusOnScreen, _) <- userToDeviceDistance starPointRadius 0+  (cx, cy) <- roundToPixels 0.5 0.5+  if radiusOnScreen >= minRadiusOnScreen+    then do arc cx cy starPointRadius 0 pi_2+            fill+    else do setAntialias AntialiasNone+            (pixel, _) <- deviceToUserDistance 1 0+            rectangle (cx - 2 * pixel) (cy - 2 * pixel) (3 * pixel) (3 * pixel)+            fill+            setAntialias AntialiasDefault+ -- | Draws the given mark on the current point.  The color should be that of the -- stone on the point, if there is one; it determines the color of the mark. drawMark :: Maybe Color -> Mark -> Render ()@@ -681,6 +770,11 @@   setLineWidth stoneVariationBorderThickness   setRgb border   stroke++roundToPixels :: Double -> Double -> Render (Double, Double)+roundToPixels =+  (uncurry deviceToUser . mapTuple (fromIntegral . (round :: Double -> Int)) <=<) .+  userToDevice  type Rgb = (Double, Double, Double) 

@@ -21,66 +21,69 @@   InfoLine,   create,   destroy,-  myLabel,+  myWidget,   ) where +import Control.Applicative ((<$>)) import Data.Maybe (fromMaybe)-import Game.Goatee.Sgf.Board-import Game.Goatee.Sgf.Monad+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Monad+import Game.Goatee.Lib.Types import Game.Goatee.Ui.Gtk.Common-import Graphics.UI.Gtk (Label, labelNew, labelSetMarkup)+import Graphics.UI.Gtk (Label, Widget, labelNew, labelSetMarkup, toWidget) -data InfoLine ui = InfoLine { myUi :: ui-                            , myRegistrations :: ViewRegistrations-                            , myLabel :: Label-                            }+data InfoLine ui = InfoLine+  { myUi :: ui+  , myState :: ViewState+  , myWidget :: Widget+  , myLabel :: Label+  } -instance UiCtrl ui => UiView (InfoLine ui) ui where+instance UiCtrl go ui => UiView go ui (InfoLine ui) where   viewName = const "InfoLine"   viewCtrl = myUi-  viewRegistrations = myRegistrations+  viewState = myState+  viewUpdate = update -create :: UiCtrl ui => ui -> IO (InfoLine ui)+create :: UiCtrl go ui => ui -> IO (InfoLine ui) create ui = do   label <- labelNew Nothing-  registrations <- viewNewRegistrations+  state <- viewStateNew    let me = InfoLine { myUi = ui-                    , myRegistrations = registrations+                    , myState = state+                    , myWidget = toWidget label                     , myLabel = label                     }    initialize me   return me -initialize :: UiCtrl ui => InfoLine ui -> IO ()+initialize :: UiCtrl go ui => InfoLine ui -> IO () initialize me = do-  let updateAfter = afterGo . updateWithCursor me =<< getCursor-  viewRegister me childAddedEvent $ const $ const updateAfter-  viewRegister me navigationEvent $ const updateAfter-  viewRegister me propertiesModifiedEvent $ const $ const updateAfter-  update me--destroy :: UiCtrl ui => InfoLine ui -> IO ()-destroy = viewUnregisterAll+  register me+    [ AnyEvent childAddedEvent+    , AnyEvent childDeletedEvent+    , AnyEvent navigationEvent+    , AnyEvent propertiesModifiedEvent+    ]+  viewUpdate me -update :: UiCtrl ui => InfoLine ui -> IO ()-update me = do-  cursor <- readCursor $ myUi me-  updateWithCursor me cursor+destroy :: UiCtrl go ui => InfoLine ui -> IO ()+destroy = viewDestroy -updateWithCursor :: UiCtrl ui => InfoLine ui -> Cursor -> IO ()-updateWithCursor me cursor =-  labelSetMarkup (myLabel me) $ generateMarkup cursor+update :: UiCtrl go ui => InfoLine ui -> IO ()+update me =+  labelSetMarkup (myLabel me) . generateMarkup =<< readCursor (myUi me)  generateMarkup :: Cursor -> String generateMarkup cursor =   let board = cursorBoard cursor       gameInfoMsg = fromMaybe "" $ do         let info = boardGameInfo board-        black <- gameInfoBlackName info-        white <- gameInfoWhiteName info-        let renderRank = maybe "" (\x -> " (" ++ x ++ ")")+        black <- sgfToString <$> gameInfoBlackName info+        white <- sgfToString <$> gameInfoWhiteName info+        let renderRank = maybe "" (\x -> " (" ++ sgfToString x ++ ")")             blackRank = renderRank $ gameInfoBlackRank info             whiteRank = renderRank $ gameInfoWhiteRank info         return $ white ++ whiteRank ++ " vs. " ++ black ++ blackRank ++ "\n"

@@ -30,9 +30,10 @@ -- | A binary switch that is off unless held on during the execution of some IO -- process.  The state of a latch can be read at any time, but can be held on by -- at most one thread at a time.-data Latch = Latch { latchValue :: IORef Bool-                   , latchLock :: MVar ()-                   }+data Latch = Latch+  { latchValue :: IORef Bool+  , latchLock :: MVar ()+  }  -- | Creates a new latch that is off. newLatch :: IO Latch

@@ -30,7 +30,7 @@ import qualified Data.Foldable as F import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (intersperse)-import Data.Maybe (fromMaybe)+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)@@ -40,6 +40,10 @@ 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,@@ -49,12 +53,15 @@   boxPackStart,   containerAdd,   deleteEvent,+  eventKeyName, eventModifier,   hPanedNew,+  keyPressEvent,   menuBarNew, menuItemNewWithMnemonic, menuItemSetSubmenu, menuNew, menuShellAppend,   notebookAppendPage, notebookNew,   on,-  panedAdd1, panedAdd2, panedSetPosition,+  panedPack1, panedPack2, panedSetPosition,   separatorMenuItemNew, separatorToolItemNew,+  toAction,   toolbarNew,   vBoxNew,   widgetDestroy, widgetGrabFocus, widgetShowAll,@@ -62,17 +69,20 @@   ) import System.IO (hPutStrLn, stderr) -data MainWindow ui = MainWindow { myUi :: ui-                                , myWindow :: Window-                                , myActions :: Actions ui-                                , myGamePropertiesPanel :: GamePropertiesPanel ui-                                , myGoban :: Goban ui-                                , myInfoLine :: InfoLine ui-                                , myDirtyChangedHandler :: IORef (Maybe Registration)-                                , myFilePathChangedHandler :: IORef (Maybe Registration)-                                }+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 ui => ui -> IO (MainWindow ui)+create :: UiCtrl go ui => ui -> IO (MainWindow ui) create ui = do   window <- windowNew   windowSetDefaultSize window 640 480@@ -112,6 +122,39 @@     , 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@@ -125,38 +168,38 @@                     toolSep <- separatorToolItemNew                     containerAdd menuToolMenu menuSep                     containerAdd toolbar toolSep) $+    catMaybes $     flip map toolOrdering $ \toolGroup ->-    forM_ toolGroup $ \tool -> do-      action <- fromMaybe (error $ "Tool has no action: " ++ show tool) <$>-                actionGroupGetAction (Actions.myToolActions actions) (show tool)-      menuItem <- actionCreateMenuItem action-      toolItem <- actionCreateToolItem action-      containerAdd menuToolMenu menuItem-      containerAdd toolbar toolItem+    let supportedTools = filter toolIsImplemented toolGroup+    in if null supportedTools+       then Nothing+       else Just $ forM_ supportedTools $ \tool -> do+         action <- fromMaybe (error $ "Tool has no action: " ++ show tool) <$>+                   actionGroupGetAction (Actions.myToolActions actions) (show tool)+         menuItem <- actionCreateMenuItem action+         toolItem <- actionCreateToolItem action+         containerAdd menuToolMenu menuItem+         containerAdd toolbar toolItem    menuView <- menuItemNewWithMnemonic "_View"   menuViewMenu <- menuNew   menuShellAppend menuBar menuView   menuItemSetSubmenu menuView menuViewMenu -  menuViewVariations <- menuItemNewWithMnemonic "_Variations"-  menuViewVariationsMenu <- menuNew-  containerAdd menuViewMenu menuViewVariations-  menuItemSetSubmenu menuViewVariations menuViewVariationsMenu--  containerAdd menuViewVariationsMenu =<<-    actionCreateMenuItem (Actions.myViewVariationsChildAction actions)-  containerAdd menuViewVariationsMenu =<<-    actionCreateMenuItem (Actions.myViewVariationsCurrentAction actions)-  containerAdd menuViewVariationsMenu =<< separatorMenuItemNew-  containerAdd menuViewVariationsMenu =<<-    actionCreateMenuItem (Actions.myViewVariationsBoardMarkupOnAction actions)-  containerAdd menuViewVariationsMenu =<<-    actionCreateMenuItem (Actions.myViewVariationsBoardMarkupOffAction actions)-   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@@ -164,7 +207,7 @@   addActionsToMenu menuHelpMenu actions [Actions.myHelpAboutAction]    infoLine <- InfoLine.create ui-  boxPackStart boardBox (InfoLine.myLabel infoLine) PackNatural 0+  boxPackStart boardBox (InfoLine.myWidget infoLine) PackNatural 0    hPaned <- hPanedNew   boxPackStart boardBox hPaned PackGrow 0@@ -176,13 +219,17 @@   panedSetPosition hPaned 400 -- (truncate (fromIntegral hPanedMax * 0.8))    goban <- Goban.create ui-  panedAdd1 hPaned $ Goban.myWidget goban+  panedPack1 hPaned (Goban.myWidget goban) True True    controlsBook <- notebookNew-  panedAdd2 hPaned controlsBook+  panedPack2 hPaned controlsBook False True +  playPanel <- PlayPanel.create ui actions   gamePropertiesPanel <- GamePropertiesPanel.create ui-  notebookAppendPage controlsBook (GamePropertiesPanel.myWidget gamePropertiesPanel) "Properties"+  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@@ -190,15 +237,28 @@   let me = MainWindow { myUi = ui                       , myWindow = window                       , myActions = actions-                      , myGamePropertiesPanel = gamePropertiesPanel-                      , myGoban = goban                       , myInfoLine = infoLine+                      , myGoban = goban+                      , myPlayPanel = playPanel+                      , myGamePropertiesPanel = gamePropertiesPanel+                      , myNodePropertiesPanel = nodePropertiesPanel                       , myDirtyChangedHandler = dirtyChangedHandler                       , myFilePathChangedHandler = filePathChangedHandler                       }    initialize me +  on window keyPressEvent $ do+    key <- eventKeyName+    mods <- eventModifier+    let km = (key, mods)+    case km of+      -- Escape focuses the goban.+      ("Escape", []) -> do+        liftIO $ widgetGrabFocus $ Goban.myWidget goban+        return True+      _ -> return False+   on window deleteEvent $ liftIO $ do     fileClose ui     return True@@ -208,7 +268,7 @@   return me  -- | Initialization that must be done after the 'UiCtrl' is available.-initialize :: UiCtrl ui => MainWindow ui -> IO ()+initialize :: UiCtrl go ui => MainWindow ui -> IO () initialize me = do   let ui = myUi me @@ -217,12 +277,14 @@   writeIORef (myFilePathChangedHandler me) =<<     liftM Just (registerFilePathChangedHandler ui "MainWindow" True $ \_ _ -> updateWindowTitle me) -destroy :: UiCtrl ui => MainWindow ui -> IO ()+destroy :: UiCtrl go ui => MainWindow ui -> IO () destroy me = do   Actions.destroy $ myActions me-  GamePropertiesPanel.destroy $ myGamePropertiesPanel me-  Goban.destroy $ myGoban 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)@@ -257,7 +319,7 @@   forM_ accessors $ \accessor ->   containerAdd menu =<< actionCreateMenuItem (accessor actions) -updateWindowTitle :: UiCtrl ui => MainWindow ui -> IO ()+updateWindowTitle :: UiCtrl go ui => MainWindow ui -> IO () updateWindowTitle me = do   let ui = myUi me   fileName <- getFileName ui

@@ -0,0 +1,249 @@+-- 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 <http://www.gnu.org/licenses/>.++-- | A list widget that displays the current node's properties for viewing and editing.+module Game.Goatee.Ui.Gtk.NodePropertiesPanel (+  NodePropertiesPanel,+  create,+  destroy,+  myWidget,+  ) where++import Control.Arrow ((+++))+import Control.Applicative ((<$>), (<*), (*>))+import Control.Monad (forM_, unless, when)+import qualified Data.Foldable as Foldable+import qualified Data.Function as Function+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (sortBy)+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Monad hiding (on)+import Game.Goatee.Lib.Parser+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Renderer+import Game.Goatee.Lib.Renderer.Tree+import Game.Goatee.Ui.Gtk.Common+import Graphics.UI.Gtk (+  AttrOp ((:=)),+  ListStore,+  Packing (PackGrow, PackNatural),+  PolicyType (PolicyAutomatic),+  ResponseId (ResponseCancel, ResponseOk),+  TreeViewColumnSizing (TreeViewColumnAutosize),+  Widget,+  WrapMode (WrapWord),+  boxPackStart,+  bufferChanged,+  buttonActivated, buttonNewWithLabel,+  cellLayoutSetAttributes, cellRendererTextNew, cellText,+  containerAdd,+  dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse,+  get,+  hBoxNew,+  labelNew, labelText,+  listStoreAppend, listStoreClear, listStoreNew, listStoreToList,+  on,+  scrolledWindowNew, scrolledWindowSetPolicy,+  set,+  stockAdd, stockCancel, stockEdit,+  textBufferText,+  textViewGetBuffer, textViewNew, textViewSetWrapMode,+  toWidget,+  treeSelectionGetSelectedRows,+  treeViewAppendColumn, treeViewColumnNew, treeViewColumnSizing, treeViewColumnPackStart,+  treeViewColumnTitle, treeViewGetSelection, treeViewNewWithModel,+  vBoxNew,+  widgetDestroy, widgetSetSensitive, widgetShowAll,+  windowSetDefaultSize, windowSetTitle,+  )+import Text.ParserCombinators.Parsec (eof, parse, spaces)++data NodePropertiesPanel ui = NodePropertiesPanel+  { myUi :: ui+  , myState :: ViewState+  , myWidget :: Widget+  , myModel :: ListStore Property+  , myModelProperties :: IORef [Property]+    -- ^ A list of properties in the same order as the rows in 'myModel'.+  }++instance UiCtrl go ui => UiView go ui (NodePropertiesPanel ui) where+  viewName = const "NodePropertiesPanel"+  viewCtrl = myUi+  viewState = myState+  viewUpdate = update++create :: UiCtrl go ui => ui -> IO (NodePropertiesPanel ui)+create ui = do+  vBox <- vBoxNew False 0++  buttonBox <- hBoxNew True 0+  boxPackStart vBox buttonBox PackNatural 0+  addButton <- buttonNewWithLabel "Add"+  editButton <- buttonNewWithLabel "Edit"+  deleteButton <- buttonNewWithLabel "Del"+  mapM_ (containerAdd buttonBox) [addButton, editButton, deleteButton]++  model <- listStoreNew []+  modelProperties <- newIORef []+  column <- treeViewColumnNew+  set column [treeViewColumnSizing := TreeViewColumnAutosize,+              treeViewColumnTitle := "Property"]+  renderer <- cellRendererTextNew+  treeViewColumnPackStart column renderer True+  cellLayoutSetAttributes column renderer model $ \property ->+    let name = propertyName property+        value = case runRender $ propertyValueRendererPretty property property of+          Left _ -> "(render error)" -- TODO Better error handling.+          Right result -> result+    in [cellText := name ++ " " ++ value]+  view <- treeViewNewWithModel model+  treeViewAppendColumn view column+  selection <- treeViewGetSelection view+  viewScroll <- scrolledWindowNew Nothing Nothing+  scrolledWindowSetPolicy viewScroll PolicyAutomatic PolicyAutomatic+  containerAdd viewScroll view+  boxPackStart vBox viewScroll PackGrow 0++  state <- viewStateNew++  let me = NodePropertiesPanel { myUi = ui+                               , myState = state+                               , myWidget = toWidget vBox+                               , myModel = model+                               , myModelProperties = modelProperties+                               }++  on addButton buttonActivated $ do+    maybeProperty <- runPropertyEditDialog "Add property" stockAdd Nothing+    Foldable.forM_ maybeProperty $ doUiGo ui . putProperty++  on editButton buttonActivated $ do+    rows <- map head <$> treeSelectionGetSelectedRows selection+    case rows of+      [] -> return ()+      row:_ -> do+        oldProperty <- (!! row) <$> readIORef modelProperties+        maybeNewProperty <- runPropertyEditDialog "Edit property" stockEdit $ Just oldProperty+        case maybeNewProperty of+          Nothing -> return ()+          Just newProperty -> doUiGo ui $ do+            -- Need to delete the old property when the property type has+            -- changed.+            deleteProperty oldProperty+            putProperty newProperty++  on deleteButton buttonActivated $ do+    rows <- map head <$> treeSelectionGetSelectedRows selection+    properties <- readIORef modelProperties+    unless (null rows) $+      doUiGo ui $ forM_ rows $ deleteProperty . (properties !!)++  register me+    [ AnyEvent navigationEvent+    , AnyEvent propertiesModifiedEvent+    ]++  viewUpdate me+  return me++destroy :: UiCtrl go ui => NodePropertiesPanel ui -> IO ()+destroy = viewDestroy++-- | Updates the 'ListStore' backing the view from the properties on the cursor.+update :: UiCtrl go ui => NodePropertiesPanel ui -> IO ()+update me = do+  cursor <- readCursor $ myUi me+  let model = myModel me+      modelProperties = myModelProperties me+      newProperties = sortBy (compare `Function.on` propertyName) $+                      cursorProperties cursor+  oldProperties <- listStoreToList model+  when (newProperties /= oldProperties) $ do+    listStoreClear model+    forM_ newProperties $ listStoreAppend model+    writeIORef modelProperties newProperties++-- | Opens a dialog for editing a property in serialized SGF format.  The+-- initial property may be absent, in which case the input box will start empty.+-- This function will eiter return 'Nothing' if the edit was cancelled, or+-- 'Just' a property if the user entered a valid property and chose to accept.+runPropertyEditDialog :: String -- ^ Dialog title.+                      -> String -- ^ Accept button label.+                      -> Maybe Property -- ^ Initial property value.+                      -> IO (Maybe Property)+runPropertyEditDialog dialogTitle acceptButtonLabel initialProperty = do+  dialog <- dialogNew+  windowSetTitle dialog dialogTitle+  windowSetDefaultSize dialog 500 225+  upper <- dialogGetUpper dialog++  helpLabel <- labelNew $ Just "Enter a property in SGF notation."+  boxPackStart upper helpLabel PackNatural 0++  textView <- textViewNew+  textViewSetWrapMode textView WrapWord+  textScroll <- scrolledWindowNew Nothing Nothing+  scrolledWindowSetPolicy textScroll PolicyAutomatic PolicyAutomatic+  containerAdd textScroll textView+  boxPackStart upper textScroll PackGrow 0+  textBuffer <- textViewGetBuffer textView++  errorLabel <- labelNew Nothing+  boxPackStart upper errorLabel PackNatural 0++  dialogAddButton dialog stockCancel ResponseCancel+  acceptButton <- dialogAddButton dialog acceptButtonLabel ResponseOk+  dialogSetDefaultResponse dialog ResponseOk++  -- Either a parse error (an empty string if the input box is empty) or a+  -- parsed property.+  currentState <- newIORef (Left "" :: Either String Property)++  let setState errorOrProperty =+        case errorOrProperty of+          Left errorMsg -> do+            set errorLabel [labelText := errorMsg]+            writeIORef currentState $ Left errorMsg+            widgetSetSensitive acceptButton False+          Right property -> do+            set errorLabel [labelText := ""]+            writeIORef currentState $ Right property+            widgetSetSensitive acceptButton True+      parseInput = do+        text <- get textBuffer textBufferText+        setState $+          if null text+          then Left ""+          else (show +++ id) $+               parse (spaces *> propertyParser <* spaces <* eof) "<property>" text++  set textBuffer [textBufferText :=+                  maybe "" (either (const "") id . runRender . renderProperty) initialProperty]+  on textBuffer bufferChanged parseInput+  parseInput++  widgetShowAll dialog+  response <- dialogRun dialog+  widgetDestroy dialog+  case response of+    ResponseOk -> do+      finalState <- readIORef currentState+      case finalState of+        Left _ -> return Nothing+        Right property -> return $ Just property+    _ -> return Nothing

@@ -0,0 +1,131 @@+-- 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 <http://www.gnu.org/licenses/>.++module Game.Goatee.Ui.Gtk.PlayPanel (+  PlayPanel,+  create,+  destroy,+  myWidget,+  ) where++import Control.Applicative ((<$>))+import Control.Monad (void)+import Game.Goatee.Common+import Game.Goatee.Lib.Board+import qualified Game.Goatee.Lib.Monad as Monad+import Game.Goatee.Lib.Monad (+  AnyEvent (..), getCursor, modifyPropertyString, navigationEvent, propertiesModifiedEvent,+  )+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Tree+import Game.Goatee.Lib.Types+import qualified Game.Goatee.Ui.Gtk.Actions as Actions+import Game.Goatee.Ui.Gtk.Actions (Actions)+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),+  actionActivate,+  boxPackStart,+  buttonActivated, buttonNewWithLabel,+  containerAdd,+  hBoxNew,+  on,+  scrolledWindowNew, scrolledWindowSetPolicy,+  textViewNew, textViewSetWrapMode,+  toWidget,+  vBoxNew,+  )++data PlayPanel ui = PlayPanel+  { myUi :: ui+  , myState :: ViewState+  , myWidget :: Widget+  , myComment :: TextView+  , myCommentSetter :: String -> IO ()+  }++instance UiCtrl go ui => UiView go ui (PlayPanel ui) where+  viewName = const "PlayPanel"+  viewCtrl = myUi+  viewState = myState+  viewUpdate = update++create :: UiCtrl go ui => ui -> Actions ui -> IO (PlayPanel ui)+create ui actions = 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 Monad.goToRoot+  on prevButton buttonActivated $ void $ goUp ui+  on nextButton buttonActivated $ void $ goDown ui 0+  on endButton buttonActivated $ doUiGo ui $+    whileM ((> 0) . length . cursorChildren <$> getCursor) $ Monad.goDown 0++  passButton <- buttonNewWithLabel "Pass"+  boxPackStart box passButton PackNatural 0+  on passButton buttonActivated $ actionActivate $ Actions.myGamePassAction actions++  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++  let me = PlayPanel+        { myUi = ui+        , myState = state+        , myWidget = toWidget box+        , myComment = comment+        , myCommentSetter = commentSetter+        }++  initialize me+  return me++initialize :: UiCtrl go ui => PlayPanel ui -> IO ()+initialize me = do+  register me+    [ AnyEvent navigationEvent+    , AnyEvent propertiesModifiedEvent+    ]+  viewUpdate me++destroy :: UiCtrl go ui => PlayPanel ui -> IO ()+destroy = viewDestroy++update :: UiCtrl go ui => PlayPanel ui -> IO ()+update me =+  readCursor (myUi me) >>=+  myCommentSetter me . maybe "" fromText . findPropertyValue propertyC . cursorNode

@@ -18,10 +18,30 @@ -- | General GTK utilities that don't exist in the Gtk2Hs. module Game.Goatee.Ui.Gtk.Utils (   onEntryChange,+  spinButtonGetValueAsBigfloat,+  textViewConfigure   ) where -import Control.Monad (void)-import Graphics.UI.Gtk (EditableClass, EntryClass, editableChanged, entryGetText, on)+import Control.Applicative ((<$>))+import Control.Monad (void, when)+import qualified Game.Goatee.Common.Bigfloat as BF+import Game.Goatee.Ui.Gtk.Latch+import Graphics.UI.Gtk (+  AttrOp ((:=)),+  EditableClass,+  EntryClass,+  SpinButtonClass,+  TextViewClass,+  bufferChanged,+  editableChanged,+  entryGetText,+  get,+  on,+  set,+  spinButtonGetValue,+  textBufferText,+  textViewBuffer,+  )  -- | Registers a handler to be called when the value contained in the entry's -- buffer changes.  The handler is called with the new value.@@ -32,3 +52,35 @@ onEntryChange entry handler =   void $ on entry editableChanged runHandler   where runHandler = entryGetText entry >>= handler++-- | Retrieves the current value of a spin button as a 'BF.Bigfloat' that's+-- rounded to the number of digits the spin button is configured for.+spinButtonGetValueAsBigfloat :: SpinButtonClass self => self -> IO BF.Bigfloat+spinButtonGetValueAsBigfloat spin = BF.fromDouble <$> spinButtonGetValue spin++-- | Configures event handlers on a 'TextView'.+textViewConfigure :: TextViewClass self => self -> (String -> IO ()) -> IO (String -> IO ())+textViewConfigure textView onViewChange = do+  -- 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.  For text+  -- views connected to models, we don't want to handle the intermediate value+  -- by writing it back to the model because this triggers dirtyness (for+  -- example, when moving between two adjacent game nodes with different+  -- comments, firing the change handler with an empty comment will change the+  -- node and make the UI dirty).  So for convenience, we hold a latch on while+  -- we are doing a model-to-view update in order to prevent the handler from+  -- firing while we're doing the assignment, then manually fire the handler+  -- afterward.  This avoids the double-assignment problem.+  buffer <- get textView textViewBuffer+  latch <- newLatch+  on buffer bufferChanged $ whenLatchOff latch $ do+    newValue <- get buffer textBufferText+    onViewChange newValue+  let setValue value = do+        oldValue <- get buffer textBufferText+        when (value /= oldValue) $ do+          withLatchOn latch $ set buffer [textBufferText := value]+          -- Like other model-view widgets, we keep firing handlers in the view+          -- and model, writing back and forth until synchronized.+          onViewChange value+  return setValue

@@ -0,0 +1,88 @@+-- 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 <http://www.gnu.org/licenses/>.++-- | Provides wrappers around regular GTK+ widgets, adding support for assigning+-- to widget values without firing signal handlers.+module Game.Goatee.Ui.Gtk.Widget (+  -- * Entry+  GoateeEntry, goateeEntryWidget, goateeEntryNew, goateeEntryGetText, goateeEntrySetText,+  goateeEntryOnChange,+  -- * Spin button+  GoateeSpinButton, goateeSpinButtonNewWithRange, goateeSpinButtonWidget, goateeSpinButtonGetValue,+  goateeSpinButtonSetValue, goateeSpinButtonOnSpinned,+  ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (void)+import qualified Game.Goatee.Common.Bigfloat as BF+import Game.Goatee.Ui.Gtk.Latch+import Game.Goatee.Ui.Gtk.Utils+import Graphics.UI.Gtk (+  AttrOp ((:=)),+  Entry,+  SpinButton,+  entryNew, entryText,+  get,+  onValueSpinned,+  set,+  spinButtonNewWithRange, spinButtonSetValue,+  )++data GoateeEntry = GoateeEntry Entry Latch++goateeEntryNew :: IO GoateeEntry+goateeEntryNew = GoateeEntry <$> entryNew <*> newLatch++goateeEntryWidget :: GoateeEntry -> Entry+goateeEntryWidget (GoateeEntry entry _) = entry++goateeEntryGetText :: GoateeEntry -> IO String+goateeEntryGetText (GoateeEntry entry _) = get entry entryText++-- | Sets an entry's value without firing handlers registered through+-- 'goateeEntryOnChange'.+goateeEntrySetText :: GoateeEntry -> String -> IO ()+goateeEntrySetText (GoateeEntry entry latch) value =+  withLatchOn latch $ set entry [entryText := value]++goateeEntryOnChange :: GoateeEntry -> (String -> IO ()) -> IO ()+goateeEntryOnChange (GoateeEntry entry latch) handler =+  onEntryChange entry $ \value -> whenLatchOff latch $ handler value++data GoateeSpinButton = GoateeSpinButton SpinButton Latch++goateeSpinButtonNewWithRange :: Double -> Double -> Double -> IO GoateeSpinButton+goateeSpinButtonNewWithRange min max step =+  GoateeSpinButton <$> spinButtonNewWithRange min max step <*> newLatch++goateeSpinButtonWidget :: GoateeSpinButton -> SpinButton+goateeSpinButtonWidget (GoateeSpinButton spinButton _) = spinButton++goateeSpinButtonGetValue :: GoateeSpinButton -> IO BF.Bigfloat+goateeSpinButtonGetValue (GoateeSpinButton spinButton _) =+  spinButtonGetValueAsBigfloat spinButton++-- | Sets a spin button's value without firing handlers registered through+-- 'goateeSpinButtonOnSpinned'.+goateeSpinButtonSetValue :: GoateeSpinButton -> BF.Bigfloat -> IO ()+goateeSpinButtonSetValue (GoateeSpinButton spinButton latch) value =+  withLatchOn latch $ spinButtonSetValue spinButton $ BF.toDouble value++goateeSpinButtonOnSpinned :: GoateeSpinButton -> (BF.Bigfloat -> IO ()) -> IO ()+goateeSpinButtonOnSpinned (GoateeSpinButton spinButton latch) handler =+  void $ onValueSpinned spinButton $ whenLatchOff latch $+  spinButtonGetValueAsBigfloat spinButton >>= handler

@@ -19,29 +19,27 @@  import Data.IORef (modifyIORef, newIORef, readIORef) import Game.Goatee.Ui.Gtk.Latch-import Test.Framework (testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))+import Test.HUnit ((~:), (@=?), Test (TestList))  {-# ANN module "HLint: ignore Reduce duplication" #-} -tests = testGroup "Game.Goatee.Ui.Gtk.Latch" [-  testCase "a new latch is off" $ do+tests = "Game.Goatee.Ui.Gtk.Latch" ~: TestList+  [ "a new latch is off" ~: do      latch <- newLatch      ref <- newIORef 0      whenLatchOff latch $ modifyIORef ref (+ 1)      whenLatchOn latch $ modifyIORef ref (+ 2)-     (1 @=?) =<< readIORef ref,+     (1 @=?) =<< readIORef ref -  testCase "a latch can be held on" $ do+  , "a latch can be held on" ~: do      latch <- newLatch      ref <- newIORef 0      withLatchOn latch $ do        whenLatchOff latch $ modifyIORef ref (+ 1)        whenLatchOn latch $ modifyIORef ref (+ 2)-     (2 @=?) =<< readIORef ref,+     (2 @=?) =<< readIORef ref -  testCase "a new latch returns to being off after it is released" $ do+  , "a new latch returns to being off after it is released" ~: do      latch <- newLatch      ref <- newIORef 0      withLatchOn latch $ do

@@ -18,10 +18,16 @@ module Main (main) where  import qualified Game.Goatee.Ui.Gtk.LatchTest-import Test.Framework (defaultMain)+import System.Exit (exitFailure, exitSuccess)+import Test.HUnit (Counts (errors, failures), Test (TestList), runTestTT) -tests = [ Game.Goatee.Ui.Gtk.LatchTest.tests-        ]+tests = TestList+  [ Game.Goatee.Ui.Gtk.LatchTest.tests+  ]  main :: IO ()-main = defaultMain tests+main = do+  counts <- runTestTT tests+  if errors counts > 0 || failures counts > 0+    then exitFailure+    else exitSuccess