-- This file is part of Goatee.
--
-- Copyright 2014-2021 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/>.

{-# LANGUAGE CPP #-}

-- | A monad for working with game trees.
module Game.Goatee.Lib.Monad (
  -- * The Go monad
  MonadGo (..),
  GoT, GoM,
  runGoT, runGo,
  evalGoT, evalGo,
  execGoT, execGo,
  Step (..),
  -- * Errors
  GoError (..),
  NavigationError (..),
  PopPositionError (..),
  DropPositionError (..),
  ModifyPropertyError (..),
  ModifyGameInfoError (..),
  NodeDeleteError (..),
  -- * Throwing monadic actions
  goUpOrThrow,
  goDownOrThrow,
  goLeftOrThrow,
  goRightOrThrow,
  popPositionOrThrow,
  dropPositionOrThrow,
  modifyPropertyOrThrow,
  modifyGameInfoOrThrow,
  deleteChildAtOrThrow,
  -- * Event handling
  Event, AnyEvent (..), eventName, fire, eventHandlerFromAction,
  -- * Events
  childAddedEvent, ChildAddedHandler,
  childDeletedEvent, ChildDeletedHandler,
  gameInfoChangedEvent, GameInfoChangedHandler,
  navigationEvent, NavigationHandler,
  propertiesModifiedEvent, PropertiesModifiedHandler,
  variationModeChangedEvent, VariationModeChangedHandler,
  ) where

#if !MIN_VERSION_containers(0,5,0)
import Control.Arrow (second)
#endif
import Control.Monad ((<=<), ap, forM, forM_, liftM, msum, unless, when)
import Control.Monad.Except (MonadError, catchError, throwError)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail, fail)
#endif
import Control.Monad.Identity (Identity, runIdentity)
import qualified Control.Monad.State as State
import Control.Monad.State (MonadState, StateT, get, put)
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer)
import qualified Data.Function as F
import Data.List (delete, find, mapAccumL, nub, sortBy)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing)
import Data.Ord (comparing)
import Game.Goatee.Common
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Property
import qualified Game.Goatee.Lib.Tree as Tree
import Game.Goatee.Lib.Tree hiding (addChild, addChildAt, deleteChildAt)
import Game.Goatee.Lib.Types
#if !MIN_VERSION_base(4,13,0)
import Prelude hiding (fail)
#endif

-- | The internal state of a Go monad transformer.  @go@ is the type of
-- Go monad or transformer (instance of 'GoMonad').
data GoState go = GoState
  { GoState go -> Cursor
stateCursor :: Cursor
    -- ^ The current position in the game tree.
  , GoState go -> PathStack
statePathStack :: PathStack
    -- ^ The current path stack.

    -- Event handlers.
  , GoState go -> [ChildAddedHandler go]
stateChildAddedHandlers :: [ChildAddedHandler go]
    -- ^ Handlers for 'childAddedEvent'.
  , GoState go -> [ChildDeletedHandler go]
stateChildDeletedHandlers :: [ChildDeletedHandler go]
    -- ^ Handlers for 'childDeletedEvent'.
  , GoState go -> [GameInfoChangedHandler go]
stateGameInfoChangedHandlers :: [GameInfoChangedHandler go]
    -- ^ Handlers for 'gameInfoChangedEvent'.
  , GoState go -> [NavigationHandler go]
stateNavigationHandlers :: [NavigationHandler go]
    -- ^ Handlers for 'navigationEvent'.
  , GoState go -> [PropertiesModifiedHandler go]
statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go]
    -- ^ Handlers for 'propertiesModifiedEvent'.
  , GoState go -> [VariationModeChangedHandler go]
stateVariationModeChangedHandlers :: [VariationModeChangedHandler go]
    -- ^ Handlers for 'variationModeChangedEvent'.
  }

-- | A path stack is a record of previous places visited in a game tree.  It is
-- encoded a list of paths (steps) to each previous memorized position.
--
-- The positions saved in calls to 'pushPosition' correspond to entries in the
-- outer list here, with the first sublist representing the last call.  The
-- sublist contains the steps in order that will trace the path back to the
-- saved position.
type PathStack = [[Step]]

-- | A simplified constructor function for 'GoState'.
initialState :: Cursor -> GoState m
initialState :: Cursor -> GoState m
initialState Cursor
cursor = GoState :: forall (go :: * -> *).
Cursor
-> PathStack
-> [ChildAddedHandler go]
-> [ChildDeletedHandler go]
-> [GameInfoChangedHandler go]
-> [NavigationHandler go]
-> [PropertiesModifiedHandler go]
-> [VariationModeChangedHandler go]
-> GoState go
GoState { stateCursor :: Cursor
stateCursor = Cursor
cursor
                              , statePathStack :: PathStack
statePathStack = []
                              , stateChildAddedHandlers :: [ChildAddedHandler m]
stateChildAddedHandlers = []
                              , stateChildDeletedHandlers :: [ChildDeletedHandler m]
stateChildDeletedHandlers = []
                              , stateGameInfoChangedHandlers :: [GameInfoChangedHandler m]
stateGameInfoChangedHandlers = []
                              , stateNavigationHandlers :: [NavigationHandler m]
stateNavigationHandlers = []
                              , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler m]
statePropertiesModifiedHandlers = []
                              , stateVariationModeChangedHandlers :: [VariationModeChangedHandler m]
stateVariationModeChangedHandlers = []
                              }

-- | A single step along a game tree.  Either up or down.
data Step =
  GoUp Int
  -- ^ Represents a step up from a child with the given index.
  | GoDown Int
    -- ^ Represents a step down to the child with the given index.
  deriving (Step -> Step -> Bool
(Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c== :: Step -> Step -> Bool
Eq, Int -> Step -> ShowS
[Step] -> ShowS
Step -> String
(Int -> Step -> ShowS)
-> (Step -> String) -> ([Step] -> ShowS) -> Show Step
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Step] -> ShowS
$cshowList :: [Step] -> ShowS
show :: Step -> String
$cshow :: Step -> String
showsPrec :: Int -> Step -> ShowS
$cshowsPrec :: Int -> Step -> ShowS
Show)

-- | Reverses a step, such that taking a step then it's reverse will leave you
-- where you started.
reverseStep :: Step -> Step
reverseStep :: Step -> Step
reverseStep Step
step = case Step
step of
  GoUp Int
index -> Int -> Step
GoDown Int
index
  GoDown Int
index -> Int -> Step
GoUp Int
index

-- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'.
takeStep :: Step -> Cursor -> Cursor
takeStep :: Step -> Cursor -> Cursor
takeStep (GoUp Int
_) Cursor
cursor = Cursor -> Maybe Cursor -> Cursor
forall a. a -> Maybe a -> a
fromMaybe (String -> Cursor
forall a. HasCallStack => String -> a
error (String -> Cursor) -> String -> Cursor
forall a b. (a -> b) -> a -> b
$ String
"takeStep: Can't go up from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Cursor -> String
forall a. Show a => a -> String
show Cursor
cursor String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".") (Maybe Cursor -> Cursor) -> Maybe Cursor -> Cursor
forall a b. (a -> b) -> a -> b
$
                           Cursor -> Maybe Cursor
cursorParent Cursor
cursor
takeStep (GoDown Int
index) Cursor
cursor = Cursor -> Int -> Cursor
cursorChild Cursor
cursor Int
index

-- | Internal function.  Takes a 'Step' in the Go monad and returns whether that
-- step was successful (i.e. if there was a node to mode to).  Updates the path
-- stack accordingly.
takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m Bool
takeStepM :: Step -> (PathStack -> PathStack) -> GoT m Bool
takeStepM Step
step = case Step
step of
  GoUp Int
_ -> (PathStack -> PathStack) -> GoT m Bool
forall (m :: * -> *).
Monad m =>
(PathStack -> PathStack) -> GoT m Bool
goUp'
  GoDown Int
index -> Int -> (PathStack -> PathStack) -> GoT m Bool
forall (m :: * -> *).
Monad m =>
Int -> (PathStack -> PathStack) -> GoT m Bool
goDown' Int
index

-- | A monad (transformer) for navigating and mutating 'Cursor's, and
-- remembering previous locations.  See 'GoT' and 'GoM'.
--
-- The monad supports handlers for events raised during actions it takes, such
-- as navigating through the tree and modifying nodes.
class (Functor go, Applicative go, Monad go) => MonadGo go where
  -- | Returns the current cursor.
  getCursor :: go Cursor

  -- | Returns the 'CoordState' at the given point.
  getCoordState :: Coord -> go CoordState
  getCoordState Coord
coord = (Cursor -> CoordState) -> go Cursor -> go CoordState
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Coord -> BoardState -> CoordState
boardCoordState Coord
coord (BoardState -> CoordState)
-> (Cursor -> BoardState) -> Cursor -> CoordState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> BoardState
cursorBoard) go Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor

  -- | Navigates up to the parent node, fires a 'navigationEvent', then returns
  -- true.  If already at the root of the tree, then none of this happens and
  -- false is returned.
  goUp :: go Bool

  -- | Navigates down the tree to the child with the given index, fires a
  -- 'navigationEvent', then returns true.  If the requested child doesn't
  -- exist, then none of this happens and false is returned.
  goDown :: Int -> go Bool

  -- | If possible, moves 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).  Fires 'navigationEvent's while moving.
  goLeft :: go Bool

  -- | If possible, moves 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).  Fires 'navigationEvent's while moving.
  goRight :: go Bool

  -- | Navigates up to the root of the tree.  Fires 'navigationEvent's for each
  -- step.
  goToRoot :: go ()

  -- | Navigates up the tree to the node containing game info properties, if
  -- any.  Returns true if a game info node was found.
  goToGameInfoNode :: Bool
                      -- ^ When no node with game info is found, then if false,
                      -- return to the original node, otherwise finish at the
                      -- root node.
                   -> go Bool

  -- | Pushes the current location in the game tree onto an internal position
  -- stack, such that 'popPosition' is capable of navigating back to the same
  -- position, even if the game tree has been modified (though the old position
  -- must still exist in the tree to return to it).
  pushPosition :: go ()

  -- | Returns to the last position pushed onto the internal position stack via
  -- 'pushPosition', if there is one.  Returns a code indicating the result of
  -- the action.
  popPosition :: go (Either PopPositionError ())

  -- | Drops the last position pushed onto the internal stack by 'pushPosition'
  -- off of the stack, if there is one.  Returns a code indicating the result of
  -- the action.
  dropPosition :: go (Either DropPositionError ())

  -- | Returns the set of properties on the current node.
  getProperties :: go [Property]
  getProperties = (Cursor -> [Property]) -> go Cursor -> go [Property]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Cursor -> [Property]
cursorProperties go Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor

  -- | Modifies the set of properties on the current node.  Fires
  -- 'propertiesModifiedEvent' after modifying if the new property set is
  -- different from the old property set (order is irrelevant).
  modifyProperties :: ([Property] -> [Property]) -> go ()

  -- | Searches for a property on the current node, returning it if found.
  getProperty :: Descriptor d => d -> go (Maybe Property)

  -- | Searches for a valued property on the current node, returning its value
  -- if found.
  getPropertyValue :: ValuedDescriptor v d => d -> go (Maybe v)
  getPropertyValue d
descriptor = (Maybe Property -> Maybe v) -> go (Maybe Property) -> go (Maybe v)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Property -> v) -> Maybe Property -> Maybe v
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Property -> v) -> Maybe Property -> Maybe v)
-> (Property -> v) -> Maybe Property -> Maybe v
forall a b. (a -> b) -> a -> b
$ d -> Property -> v
forall v a. ValuedDescriptor v a => a -> Property -> v
propertyValue d
descriptor) (go (Maybe Property) -> go (Maybe v))
-> go (Maybe Property) -> go (Maybe v)
forall a b. (a -> b) -> a -> b
$ d -> go (Maybe Property)
forall (go :: * -> *) d.
(MonadGo go, Descriptor d) =>
d -> go (Maybe Property)
getProperty d
descriptor

  -- | Sets a property on the current node, replacing an existing property with
  -- the same name, if one exists.  Fires 'propertiesModifiedEvent' if the
  -- property has changed.
  putProperty :: Property -> go ()
  putProperty Property
property = do
    Either ModifyPropertyError ()
result <- Property
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
forall (go :: * -> *) d.
(MonadGo go, Descriptor d) =>
d
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
modifyProperty Property
property ((Maybe Property -> Maybe Property)
 -> go (Either ModifyPropertyError ()))
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
forall a b. (a -> b) -> a -> b
$ Maybe Property -> Maybe Property -> Maybe Property
forall a b. a -> b -> a
const (Maybe Property -> Maybe Property -> Maybe Property)
-> Maybe Property -> Maybe Property -> Maybe Property
forall a b. (a -> b) -> a -> b
$ Property -> Maybe Property
forall a. a -> Maybe a
Just Property
property
    case Either ModifyPropertyError ()
result of
      Right () -> () -> go ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Left (ModifyPropertyCannotChangeType String
old String
new) ->
        String -> go ()
forall a. HasCallStack => String -> a
error (String -> go ()) -> String -> go ()
forall a b. (a -> b) -> a -> b
$ String
"MonadGo.putProperty: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"Internal error, should not have attempted to change property type " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"(old '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
old String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"', new '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
new String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"')."

  -- | Deletes a property from the current node, if it's set, and fires
  -- 'propertiesModifiedEvent'.
  --
  -- Note that although a 'Property' is a 'Descriptor', giving a valued
  -- @Property@ here will not cause deletion to match on the value of the
  -- property.  That is, the following code will result in 'Nothing', because
  -- the deletion only cares about the name of the property.
  --
  -- > do putProperty $ PL Black
  -- >    deleteProperty $ PL White
  -- >    getPropertyValue propertyPL
  deleteProperty :: Descriptor d => d -> go ()
  deleteProperty d
descriptor = do
    Either ModifyPropertyError ()
result <- d
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
forall (go :: * -> *) d.
(MonadGo go, Descriptor d) =>
d
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
modifyProperty d
descriptor ((Maybe Property -> Maybe Property)
 -> go (Either ModifyPropertyError ()))
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
forall a b. (a -> b) -> a -> b
$ Maybe Property -> Maybe Property -> Maybe Property
forall a b. a -> b -> a
const Maybe Property
forall a. Maybe a
Nothing
    case Either ModifyPropertyError ()
result of
      Right () -> () -> go ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Left (ModifyPropertyCannotChangeType String
old String
new) ->
        String -> go ()
forall a. HasCallStack => String -> a
error (String -> go ()) -> String -> go ()
forall a b. (a -> b) -> a -> b
$ String
"MonadGo.deleteProperty: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"Internal error, should not have attempted to change property type " String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"(old '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
old String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"', new '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
new String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"')."

  -- | Calls the given function to modify the state of the given property
  -- (descriptor) on the current node.  'Nothing' represents the property not
  -- existing on the node, and a 'Just' marks the property's presence.  Fires
  -- 'propertiesModifiedEvent' if the property changed.  This function does not
  -- do any validation to check that the resulting tree state is valid.
  --
  -- The given function is not allowed to change the property into a different
  -- property.  Instead, the old property should be removed and the new property
  -- should be inserted separately.  If the function does this,
  -- 'ModifyPropertyCannotChangeType' is returned and no modification takes
  -- place.
  modifyProperty :: Descriptor d
                 => d
                 -> (Maybe Property -> Maybe Property)
                 -> go (Either ModifyPropertyError ())

  -- | Calls the given function to modify the state of the given valued property
  -- (descriptor) on the current node.  'Nothing' represents the property not
  -- existing on the node, and a 'Just' with the property's value marks the
  -- property's presence.  Fires 'propertiesModifiedEvent' if the property
  -- changed.  This function does not do any validation to check that the
  -- resulting tree state is valid.
  modifyPropertyValue :: ValuedDescriptor v d => d -> (Maybe v -> Maybe v) -> go ()
  modifyPropertyValue d
descriptor Maybe v -> Maybe v
fn = d
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
forall (go :: * -> *) d.
(MonadGo go, Descriptor d) =>
d
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
modifyProperty d
descriptor Maybe Property -> Maybe Property
modify go (Either ModifyPropertyError ())
-> (Either ModifyPropertyError () -> go ()) -> go ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right () -> () -> go ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left (ModifyPropertyCannotChangeType String
old String
new) ->
      String -> go ()
forall a. HasCallStack => String -> a
error (String -> go ()) -> String -> go ()
forall a b. (a -> b) -> a -> b
$ String
"MonadGo.modifyPropertyValue: Internal error, attempted to change " String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
"property type (old '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
old String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"', new '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
new String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"')."
    where modify :: Maybe Property -> Maybe Property
modify Maybe Property
old =
            d -> v -> Property
forall v a. ValuedDescriptor v a => a -> v -> Property
propertyBuilder d
descriptor (v -> Property) -> Maybe v -> Maybe Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe v -> Maybe v
fn (d -> Property -> v
forall v a. ValuedDescriptor v a => a -> Property -> v
propertyValue d
descriptor (Property -> v) -> Maybe Property -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Property
old)

  -- | Mutates the string-valued property attached to the current node according
  -- to the given function.  The input string will be empty if the current node
  -- either has the property with an empty value, or doesn't have the property.
  -- Returning an empty string removes the property from the node, if it was
  -- set.  Fires 'propertiesModifiedEvent' if the property changed.
  modifyPropertyString :: (Stringlike s, ValuedDescriptor s d) => d -> (String -> String) -> go ()
  modifyPropertyString d
descriptor ShowS
fn =
    d -> (Maybe s -> Maybe s) -> go ()
forall (go :: * -> *) v d.
(MonadGo go, ValuedDescriptor v d) =>
d -> (Maybe v -> Maybe v) -> go ()
modifyPropertyValue d
descriptor ((Maybe s -> Maybe s) -> go ()) -> (Maybe s -> Maybe s) -> go ()
forall a b. (a -> b) -> a -> b
$ \Maybe s
value -> case ShowS
fn (String -> (s -> String) -> Maybe s -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" s -> String
forall a. Stringlike a => a -> String
sgfToString Maybe s
value) of
      String
"" -> Maybe s
forall a. Maybe a
Nothing
      String
str -> let sgf :: s
sgf = String -> s
forall a. Stringlike a => String -> a
stringToSgf String
str
                 -- Because stringToSgf might do processing, we have to check
                 -- the conversion back to a string for emptiness.
             in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ s -> String
forall a. Stringlike a => a -> String
sgfToString s
sgf then Maybe s
forall a. Maybe a
Nothing else s -> Maybe s
forall a. a -> Maybe a
Just s
sgf

  -- | Mutates the list-valued property attached to the current node
  -- according to the given function.  The input list will be empty if the
  -- current node either has the property with an empty value, or doesn't have
  -- the property.  Returning an empty list removes the property from the node,
  -- if it was set.
  --
  -- Fires 'propertiesModifiedEvent' if the property changed.
  --
  -- See also 'modifyPropertyCoords'.
  modifyPropertyList :: ValuedDescriptor [v] d => d -> ([v] -> [v]) -> go ()
  modifyPropertyList d
descriptor [v] -> [v]
fn =
    d -> (Maybe [v] -> Maybe [v]) -> go ()
forall (go :: * -> *) v d.
(MonadGo go, ValuedDescriptor v d) =>
d -> (Maybe v -> Maybe v) -> go ()
modifyPropertyValue d
descriptor ((Maybe [v] -> Maybe [v]) -> go ())
-> (Maybe [v] -> Maybe [v]) -> go ()
forall a b. (a -> b) -> a -> b
$ \Maybe [v]
value -> case [v] -> [v]
fn ([v] -> [v]) -> [v] -> [v]
forall a b. (a -> b) -> a -> b
$ [v] -> Maybe [v] -> [v]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [v]
value of
      [] -> Maybe [v]
forall a. Maybe a
Nothing
      [v]
value' -> [v] -> Maybe [v]
forall a. a -> Maybe a
Just [v]
value'

  -- | Mutates the 'CoordList'-valued property attached to the current node
  -- according to the given function.  Conversion between @CoordList@ and
  -- @[Coord]@ is performed automatically.  The input list will be empty if the
  -- current node either has the property with an empty value, or doesn't have
  -- the property.  Returning an empty list removes the property from the node,
  -- if it was set.
  --
  -- Importantly, this might not be specific enough for properties such as 'DD'
  -- and 'VW' where a present, empty list has different semantics from the
  -- property not being present.  In that case, 'modifyPropertyValue' is better.
  --
  -- Fires 'propertiesModifiedEvent' if the property changed.
  modifyPropertyCoords :: ValuedDescriptor CoordList d => d -> ([Coord] -> [Coord]) -> go ()
  modifyPropertyCoords d
descriptor [Coord] -> [Coord]
fn =
    d -> (Maybe CoordList -> Maybe CoordList) -> go ()
forall (go :: * -> *) v d.
(MonadGo go, ValuedDescriptor v d) =>
d -> (Maybe v -> Maybe v) -> go ()
modifyPropertyValue d
descriptor ((Maybe CoordList -> Maybe CoordList) -> go ())
-> (Maybe CoordList -> Maybe CoordList) -> go ()
forall a b. (a -> b) -> a -> b
$ \Maybe CoordList
value -> case [Coord] -> [Coord]
fn ([Coord] -> [Coord]) -> [Coord] -> [Coord]
forall a b. (a -> b) -> a -> b
$ [Coord] -> (CoordList -> [Coord]) -> Maybe CoordList -> [Coord]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CoordList -> [Coord]
expandCoordList Maybe CoordList
value of
      [] -> Maybe CoordList
forall a. Maybe a
Nothing
      [Coord]
coords -> CoordList -> Maybe CoordList
forall a. a -> Maybe a
Just (CoordList -> Maybe CoordList) -> CoordList -> Maybe CoordList
forall a b. (a -> b) -> a -> b
$ [Coord] -> CoordList
buildCoordList [Coord]
coords

  -- | Mutates the game info for the current path, returning the new info.  If
  -- the current node or one of its ancestors has game info properties, then
  -- that node is modified.  Otherwise, properties are inserted on the root
  -- node.  The return value on success is @(oldGameInfo, newGameInfo)@.
  --
  -- The given function is not allowed to modify the 'RootInfo' within the
  -- 'GameInfo'.  If this happens, an error code is returned and no
  -- modifications are made.
  modifyGameInfo :: (GameInfo -> GameInfo)
                 -> go (Either ModifyGameInfoError (GameInfo, GameInfo))

  -- | Sets the game's 'VariationMode' via the 'ST' property on the root node,
  -- then fires a 'variationModeChangedEvent' if the variation mode has changed.
  modifyVariationMode :: (VariationMode -> VariationMode) -> go ()

  -- | Retrieves the stone assigned in the current node to a point by 'AB',
  -- 'AE', or 'AW'.  The possible results are:
  --
  -- * @Nothing@: No stone has been assigned to the point.  The point could
  -- still be in any state, e.g. from a play on the current node or some
  -- property in an ancestor node.
  --
  -- * @Just Nothing@: The point has been assigned to be empty.
  --
  -- * @Just (Just Color)@: The point has been assigned to have a stone of the
  -- given color.
  getAssignedStone :: Coord -> go (Maybe (Maybe Color))
  getAssignedStone Coord
coord =
    ([Maybe (Maybe Color)] -> Maybe (Maybe Color))
-> go [Maybe (Maybe Color)] -> go (Maybe (Maybe Color))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Maybe Color)] -> Maybe (Maybe Color)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (go [Maybe (Maybe Color)] -> go (Maybe (Maybe Color)))
-> go [Maybe (Maybe Color)] -> go (Maybe (Maybe Color))
forall a b. (a -> b) -> a -> b
$ [AnyCoordListDescriptor]
-> (AnyCoordListDescriptor -> go (Maybe (Maybe Color)))
-> go [Maybe (Maybe Color)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnyCoordListDescriptor]
stoneAssignmentProperties ((AnyCoordListDescriptor -> go (Maybe (Maybe Color)))
 -> go [Maybe (Maybe Color)])
-> (AnyCoordListDescriptor -> go (Maybe (Maybe Color)))
-> go [Maybe (Maybe Color)]
forall a b. (a -> b) -> a -> b
$ \AnyCoordListDescriptor
descriptor ->
    ((\[Coord]
coords -> if Coord
coord Coord -> [Coord] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Coord]
coords
                 then Maybe Color -> Maybe (Maybe Color)
forall a. a -> Maybe a
Just (Maybe Color -> Maybe (Maybe Color))
-> Maybe Color -> Maybe (Maybe Color)
forall a b. (a -> b) -> a -> b
$ AnyCoordListDescriptor -> Maybe Color
stoneAssignmentPropertyToStone AnyCoordListDescriptor
descriptor
                 else Maybe (Maybe Color)
forall a. Maybe a
Nothing) ([Coord] -> Maybe (Maybe Color))
-> (Maybe CoordList -> Maybe [Coord])
-> Maybe CoordList
-> Maybe (Maybe Color)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
     (CoordList -> [Coord]) -> Maybe CoordList -> Maybe [Coord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoordList -> [Coord]
expandCoordList) (Maybe CoordList -> Maybe (Maybe Color))
-> go (Maybe CoordList) -> go (Maybe (Maybe Color))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    AnyCoordListDescriptor -> go (Maybe CoordList)
forall (go :: * -> *) v d.
(MonadGo go, ValuedDescriptor v d) =>
d -> go (Maybe v)
getPropertyValue AnyCoordListDescriptor
descriptor

  -- | Looks up all stones that are assigned by 'AB', 'AE', or 'AW' properties
  -- on the current node.  Returns a map from each point to the stone that is
  -- assigned to the point.
  getAllAssignedStones :: go (Map Coord (Maybe Color))
  getAllAssignedStones =
    ([Map Coord (Maybe Color)] -> Map Coord (Maybe Color))
-> go [Map Coord (Maybe Color)] -> go (Map Coord (Maybe Color))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map Coord (Maybe Color)] -> Map Coord (Maybe Color)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (go [Map Coord (Maybe Color)] -> go (Map Coord (Maybe Color)))
-> go [Map Coord (Maybe Color)] -> go (Map Coord (Maybe Color))
forall a b. (a -> b) -> a -> b
$ [AnyCoordListDescriptor]
-> (AnyCoordListDescriptor -> go (Map Coord (Maybe Color)))
-> go [Map Coord (Maybe Color)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnyCoordListDescriptor]
stoneAssignmentProperties ((AnyCoordListDescriptor -> go (Map Coord (Maybe Color)))
 -> go [Map Coord (Maybe Color)])
-> (AnyCoordListDescriptor -> go (Map Coord (Maybe Color)))
-> go [Map Coord (Maybe Color)]
forall a b. (a -> b) -> a -> b
$ \AnyCoordListDescriptor
descriptor ->
    let stone :: Maybe Color
stone = AnyCoordListDescriptor -> Maybe Color
stoneAssignmentPropertyToStone AnyCoordListDescriptor
descriptor
    in [(Coord, Maybe Color)] -> Map Coord (Maybe Color)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Coord, Maybe Color)] -> Map Coord (Maybe Color))
-> (Maybe CoordList -> [(Coord, Maybe Color)])
-> Maybe CoordList
-> Map Coord (Maybe Color)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coord -> (Coord, Maybe Color))
-> [Coord] -> [(Coord, Maybe Color)]
forall a b. (a -> b) -> [a] -> [b]
map (\Coord
coord -> (Coord
coord, Maybe Color
stone)) ([Coord] -> [(Coord, Maybe Color)])
-> (Maybe CoordList -> [Coord])
-> Maybe CoordList
-> [(Coord, Maybe Color)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Coord] -> (CoordList -> [Coord]) -> Maybe CoordList -> [Coord]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CoordList -> [Coord]
expandCoordList (Maybe CoordList -> Map Coord (Maybe Color))
-> go (Maybe CoordList) -> go (Map Coord (Maybe Color))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       AnyCoordListDescriptor -> go (Maybe CoordList)
forall (go :: * -> *) v d.
(MonadGo go, ValuedDescriptor v d) =>
d -> go (Maybe v)
getPropertyValue AnyCoordListDescriptor
descriptor

  -- | Modifies the state of currently assigned stones, keeping in mind that it
  -- is invalid to mix 'MoveProperty' and 'SetupProperty' properties in a single
  -- node.  This function has the behaviour of a user changing stone assignments
  -- in a UI.  How this function works is:
  --
  -- * Pick a node to work with.  If there is a move property on the current
  -- node and there is not already a setup property on the current node, then
  -- we'll create and modify a new child node.  Otherwise, either there are no
  -- move properties on the node (so we can add setup properties at will), or
  -- there are both move and setup properties on the node (the node is already
  -- invalid), so we'll just modify the current node.
  --
  -- * If we're modifying the current node, then apply the modification function
  -- to the state of stone assignment for each coordinate.  See
  -- 'getAssignedStone' for the meaning of @Maybe (Maybe Color)@.  Modify the
  -- properties in the node as necessary to apply the result
  -- ('propertiesModifiedEvent').  (__NOTE:__ Currently one event is fired for
  -- each property modified; this may change in the future.)
  --
  -- * If we need to create a child node, then apply the modification function
  -- to 'Nothing' to determine if we're actually adding assignments.  If the
  -- function returns a 'Just', then we create a child node with the necessary
  -- assignment properties, insert it ('childAddedEvent'), then navigate to it
  -- ('navigationEvent').  If the function returns 'Nothing', then
  -- 'modifyAssignedStones' does nothing.
  modifyAssignedStones :: [Coord] -> (Maybe (Maybe Color) -> Maybe (Maybe Color)) -> go ()
  modifyAssignedStones [Coord]
coords Maybe (Maybe Color) -> Maybe (Maybe Color)
f = do
    Bool
needChild <- (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> ([PropertyType] -> Bool) -> [PropertyType] -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PropertyType -> [PropertyType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem PropertyType
SetupProperty ([PropertyType] -> Bool -> Bool)
-> ([PropertyType] -> Bool) -> [PropertyType] -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PropertyType -> [PropertyType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem PropertyType
MoveProperty) ([PropertyType] -> Bool)
-> ([Property] -> [PropertyType]) -> [Property] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (Property -> PropertyType) -> [Property] -> [PropertyType]
forall a b. (a -> b) -> [a] -> [b]
map Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType ([Property] -> Bool) -> go [Property] -> go Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 go [Property]
forall (go :: * -> *). MonadGo go => go [Property]
getProperties
    if Bool
needChild
      then case Maybe (Maybe Color) -> Maybe (Maybe Color)
f Maybe (Maybe Color)
forall a. Maybe a
Nothing of
        Maybe (Maybe Color)
Nothing -> () -> go ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Maybe Color
assignedStone -> do
          Node -> go ()
forall (go :: * -> *). MonadGo go => Node -> go ()
addChild Node
emptyNode { nodeProperties :: [Property]
nodeProperties =
                               [AnyCoordListDescriptor -> CoordList -> Property
forall v a. ValuedDescriptor v a => a -> v -> Property
propertyBuilder (Maybe Color -> AnyCoordListDescriptor
stoneToStoneAssignmentProperty Maybe Color
assignedStone) (CoordList -> Property) -> CoordList -> Property
forall a b. (a -> b) -> a -> b
$
                                [Coord] -> CoordList
buildCoordList [Coord]
coords]
                             }
          Bool
ok <- Int -> go Bool
forall (go :: * -> *). MonadGo go => Int -> go Bool
goDown (Int -> go Bool) -> go Int -> go Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> (Cursor -> Int) -> Cursor -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cursor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Cursor] -> Int) -> (Cursor -> [Cursor]) -> Cursor -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> [Cursor]
cursorChildren (Cursor -> Int) -> go Cursor -> go Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> go Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
          Bool -> go () -> go ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (go () -> go ()) -> go () -> go ()
forall a b. (a -> b) -> a -> b
$ String -> go ()
forall a. HasCallStack => String -> a
error String
"GoT.modifyAssignedStones: Failed to move to new child."
      else do
        -- Get a map from getAllAssignedStones: Map Coord (Maybe Color)
        Map Coord (Maybe Color)
allAssignedStones <- go (Map Coord (Maybe Color))
forall (go :: * -> *). MonadGo go => go (Map Coord (Maybe Color))
getAllAssignedStones
        let -- For each coord in coords, modify the map.
            allAssignedStones' :: Map Coord (Maybe Color)
allAssignedStones' = (Coord -> Map Coord (Maybe Color) -> Map Coord (Maybe Color))
-> Map Coord (Maybe Color) -> [Coord] -> Map Coord (Maybe Color)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Maybe (Maybe Color) -> Maybe (Maybe Color))
-> Coord -> Map Coord (Maybe Color) -> Map Coord (Maybe Color)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Maybe Color) -> Maybe (Maybe Color)
f) Map Coord (Maybe Color)
allAssignedStones [Coord]
coords
            -- Invert both maps.
            byStone, byStone' :: Map (Maybe Color) [Coord]
            byStone :: Map (Maybe Color) [Coord]
byStone = Map Coord (Maybe Color) -> Map (Maybe Color) [Coord]
forall v k. Ord v => Map k v -> Map v [k]
mapInvert Map Coord (Maybe Color)
allAssignedStones
            byStone' :: Map (Maybe Color) [Coord]
byStone' = Map Coord (Maybe Color) -> Map (Maybe Color) [Coord]
forall v k. Ord v => Map k v -> Map v [k]
mapInvert Map Coord (Maybe Color)
allAssignedStones'
            -- Compute a diff between the two maps.
            diff :: Map (Maybe Color) ([Coord], [Coord])
#if MIN_VERSION_containers(0,5,0)
            diff :: Map (Maybe Color) ([Coord], [Coord])
diff = (Maybe Color -> [Coord] -> [Coord] -> Maybe ([Coord], [Coord]))
-> (Map (Maybe Color) [Coord]
    -> Map (Maybe Color) ([Coord], [Coord]))
-> (Map (Maybe Color) [Coord]
    -> Map (Maybe Color) ([Coord], [Coord]))
-> Map (Maybe Color) [Coord]
-> Map (Maybe Color) [Coord]
-> Map (Maybe Color) ([Coord], [Coord])
forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
                   (\Maybe Color
_ [Coord]
oldCoords [Coord]
newCoords -> if [Coord]
newCoords [Coord] -> [Coord] -> Bool
forall a. Eq a => a -> a -> Bool
== [Coord]
oldCoords
                                              then Maybe ([Coord], [Coord])
forall a. Maybe a
Nothing
                                              else ([Coord], [Coord]) -> Maybe ([Coord], [Coord])
forall a. a -> Maybe a
Just ([Coord]
oldCoords, [Coord]
newCoords))
                   (([Coord] -> ([Coord], [Coord]))
-> Map (Maybe Color) [Coord]
-> Map (Maybe Color) ([Coord], [Coord])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (([Coord] -> ([Coord], [Coord]))
 -> Map (Maybe Color) [Coord]
 -> Map (Maybe Color) ([Coord], [Coord]))
-> ([Coord] -> ([Coord], [Coord]))
-> Map (Maybe Color) [Coord]
-> Map (Maybe Color) ([Coord], [Coord])
forall a b. (a -> b) -> a -> b
$ \[Coord]
oldCoords -> ([Coord]
oldCoords, []))
                   (([Coord] -> ([Coord], [Coord]))
-> Map (Maybe Color) [Coord]
-> Map (Maybe Color) ([Coord], [Coord])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (([Coord] -> ([Coord], [Coord]))
 -> Map (Maybe Color) [Coord]
 -> Map (Maybe Color) ([Coord], [Coord]))
-> ([Coord] -> ([Coord], [Coord]))
-> Map (Maybe Color) [Coord]
-> Map (Maybe Color) ([Coord], [Coord])
forall a b. (a -> b) -> a -> b
$ \[Coord]
newCoords -> ([], [Coord]
newCoords))
                   Map (Maybe Color) [Coord]
byStone
                   Map (Maybe Color) [Coord]
byStone'
#else
            -- GHC 7.4.2 / containers <0.5.0 don't provide map merging.
            diff = (\partialDiff ->
                     foldr (\(stone, new) ->
                             Map.alter (Just . maybe ([], new) (second $ const new))
                                       stone)
                           partialDiff
                           (Map.assocs byStone')) $
                   Map.map (\old -> (old, [])) byStone
#endif
        -- Modify the AB,AE,AW properties for the stones that have changed lists.
        [(Maybe Color, ([Coord], [Coord]))]
-> ((Maybe Color, ([Coord], [Coord])) -> go ()) -> go ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map (Maybe Color) ([Coord], [Coord])
-> [(Maybe Color, ([Coord], [Coord]))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map (Maybe Color) ([Coord], [Coord])
diff) (((Maybe Color, ([Coord], [Coord])) -> go ()) -> go ())
-> ((Maybe Color, ([Coord], [Coord])) -> go ()) -> go ()
forall a b. (a -> b) -> a -> b
$ \(Maybe Color
stone, ([Coord]
oldCoords, [Coord]
newCoords)) ->
          Bool -> go () -> go ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Coord]
newCoords [Coord] -> [Coord] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Coord]
oldCoords) (go () -> go ()) -> go () -> go ()
forall a b. (a -> b) -> a -> b
$
          AnyCoordListDescriptor -> ([Coord] -> [Coord]) -> go ()
forall (go :: * -> *) d.
(MonadGo go, ValuedDescriptor CoordList d) =>
d -> ([Coord] -> [Coord]) -> go ()
modifyPropertyCoords (Maybe Color -> AnyCoordListDescriptor
stoneToStoneAssignmentProperty Maybe Color
stone) (([Coord] -> [Coord]) -> go ()) -> ([Coord] -> [Coord]) -> go ()
forall a b. (a -> b) -> a -> b
$ [Coord] -> [Coord] -> [Coord]
forall a b. a -> b -> a
const [Coord]
newCoords

  -- | Returns the 'Mark' at a point on the current node.
  getMark :: Coord -> go (Maybe Mark)
  getMark = (CoordState -> Maybe Mark) -> go CoordState -> go (Maybe Mark)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CoordState -> Maybe Mark
coordMark (go CoordState -> go (Maybe Mark))
-> (Coord -> go CoordState) -> Coord -> go (Maybe Mark)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coord -> go CoordState
forall (go :: * -> *). MonadGo go => Coord -> go CoordState
getCoordState

  -- | Calls the given function to modify the presence of a 'Mark' on the
  -- current node.
  modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go ()
  modifyMark Maybe Mark -> Maybe Mark
f Coord
coord = do
    Maybe Mark
maybeOldMark <- Coord -> go (Maybe Mark)
forall (go :: * -> *). MonadGo go => Coord -> go (Maybe Mark)
getMark Coord
coord
    case (Maybe Mark
maybeOldMark, Maybe Mark -> Maybe Mark
f Maybe Mark
maybeOldMark) of
      (Just Mark
oldMark, Maybe Mark
Nothing) -> Mark -> go ()
forall (go :: * -> *). MonadGo go => Mark -> go ()
remove Mark
oldMark
      (Maybe Mark
Nothing, Just Mark
newMark) -> Mark -> go ()
forall (go :: * -> *). MonadGo go => Mark -> go ()
add Mark
newMark
      (Just Mark
oldMark, Just Mark
newMark) | Mark
oldMark Mark -> Mark -> Bool
forall a. Eq a => a -> a -> Bool
/= Mark
newMark -> Mark -> go ()
forall (go :: * -> *). MonadGo go => Mark -> go ()
remove Mark
oldMark go () -> go () -> go ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Mark -> go ()
forall (go :: * -> *). MonadGo go => Mark -> go ()
add Mark
newMark
      (Just Mark
_, Just Mark
_) -> () -> go ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (Maybe Mark
Nothing, Maybe Mark
Nothing) -> () -> go ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where remove :: Mark -> go ()
remove Mark
mark = ValuedPropertyInfo CoordList -> ([Coord] -> [Coord]) -> go ()
forall (go :: * -> *) d.
(MonadGo go, ValuedDescriptor CoordList d) =>
d -> ([Coord] -> [Coord]) -> go ()
modifyPropertyCoords (Mark -> ValuedPropertyInfo CoordList
markProperty Mark
mark) (Coord -> [Coord] -> [Coord]
forall a. Eq a => a -> [a] -> [a]
delete Coord
coord)
          add :: Mark -> go ()
add Mark
mark = ValuedPropertyInfo CoordList -> ([Coord] -> [Coord]) -> go ()
forall (go :: * -> *) d.
(MonadGo go, ValuedDescriptor CoordList d) =>
d -> ([Coord] -> [Coord]) -> go ()
modifyPropertyCoords (Mark -> ValuedPropertyInfo CoordList
markProperty Mark
mark) (Coord
coordCoord -> [Coord] -> [Coord]
forall a. a -> [a] -> [a]
:)

  -- | Adds a child node to the current node at the end of the current node's
  -- child list.  Fires a 'childAddedEvent' after the child is added.
  addChild :: Node -> go ()
  addChild Node
node = do
    Int
childCount <- (Cursor -> Int) -> go Cursor -> go Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Cursor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Cursor] -> Int) -> (Cursor -> [Cursor]) -> Cursor -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> [Cursor]
cursorChildren) go Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    Int -> Node -> go ()
forall (go :: * -> *). MonadGo go => Int -> Node -> go ()
addChildAt Int
childCount Node
node

  -- | Adds a child node to the current node at the given index, shifting all
  -- existing children at and after the index to the right.  The index must be
  -- in the range @[0, numberOfChildren]@; if it is not, it will be capped to
  -- this range.  Fires a 'childAddedEvent' after the child is added.
  addChildAt :: Int -> Node -> go ()

  -- | Tries to remove the child node at the given index below the current node.
  -- Returns a status code indicating whether the deletion succeeded, or why
  -- not.
  deleteChildAt :: Int -> go (Either NodeDeleteError ())

  -- | Registers a new event handler for a given event type.
  on :: Event go h -> h -> go ()

  -- | Registers a new event handler for a given event type.  Unlike 'on', whose
  -- handler may receive arguments, the handler given here doesn't receive any
  -- arguments.
  on0 :: Event go h -> go () -> go ()
  on0 Event go h
event go ()
handler = Event go h -> h -> go ()
forall (go :: * -> *) h. MonadGo go => Event go h -> h -> go ()
on Event go h
event (h -> go ()) -> h -> go ()
forall a b. (a -> b) -> a -> b
$ Event go h -> go () -> h
forall (go :: * -> *) h. Event go h -> go () -> h
eventHandlerFromAction Event go h
event go ()
handler

-- | All of the types of errors that 'MonadGo' functions can return.
data GoError =
  GoNavigationError NavigationError
  | GoPopPositionError PopPositionError
  | GoDropPositionError DropPositionError
  | GoModifyPropertyError ModifyPropertyError
  | GoModifyGameInfoError ModifyGameInfoError
  | GoNodeDeleteError NodeDeleteError
  deriving (GoError -> GoError -> Bool
(GoError -> GoError -> Bool)
-> (GoError -> GoError -> Bool) -> Eq GoError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GoError -> GoError -> Bool
$c/= :: GoError -> GoError -> Bool
== :: GoError -> GoError -> Bool
$c== :: GoError -> GoError -> Bool
Eq, Int -> GoError -> ShowS
[GoError] -> ShowS
GoError -> String
(Int -> GoError -> ShowS)
-> (GoError -> String) -> ([GoError] -> ShowS) -> Show GoError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GoError] -> ShowS
$cshowList :: [GoError] -> ShowS
show :: GoError -> String
$cshow :: GoError -> String
showsPrec :: Int -> GoError -> ShowS
$cshowsPrec :: Int -> GoError -> ShowS
Show)

-- | Errors from attempting to navigate.  Thrown by 'goUpOrThrow',
-- 'goDownOrThrow', 'goLeftOrThrow', 'goRightOrThrow'.
data NavigationError =
  NavigationCouldNotMove
  -- ^ Could not make the requested motion.
  deriving (NavigationError -> NavigationError -> Bool
(NavigationError -> NavigationError -> Bool)
-> (NavigationError -> NavigationError -> Bool)
-> Eq NavigationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NavigationError -> NavigationError -> Bool
$c/= :: NavigationError -> NavigationError -> Bool
== :: NavigationError -> NavigationError -> Bool
$c== :: NavigationError -> NavigationError -> Bool
Eq, Int -> NavigationError -> ShowS
[NavigationError] -> ShowS
NavigationError -> String
(Int -> NavigationError -> ShowS)
-> (NavigationError -> String)
-> ([NavigationError] -> ShowS)
-> Show NavigationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NavigationError] -> ShowS
$cshowList :: [NavigationError] -> ShowS
show :: NavigationError -> String
$cshow :: NavigationError -> String
showsPrec :: Int -> NavigationError -> ShowS
$cshowsPrec :: Int -> NavigationError -> ShowS
Show)

-- | Errors from 'popPosition'.
data PopPositionError =
  PopPositionStackEmpty
  -- ^ There is no previous position to return to.  No action was taken.
  | PopPositionCannotRetraceSteps
    -- ^ The previous position could not be returned to, because the game tree
    -- has been modified.  The current position in the game tree is where motion
    -- reached when it could go no further.  This is probably not useful, and
    -- computation should be abandoned.
  deriving (PopPositionError -> PopPositionError -> Bool
(PopPositionError -> PopPositionError -> Bool)
-> (PopPositionError -> PopPositionError -> Bool)
-> Eq PopPositionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PopPositionError -> PopPositionError -> Bool
$c/= :: PopPositionError -> PopPositionError -> Bool
== :: PopPositionError -> PopPositionError -> Bool
$c== :: PopPositionError -> PopPositionError -> Bool
Eq, Int -> PopPositionError -> ShowS
[PopPositionError] -> ShowS
PopPositionError -> String
(Int -> PopPositionError -> ShowS)
-> (PopPositionError -> String)
-> ([PopPositionError] -> ShowS)
-> Show PopPositionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PopPositionError] -> ShowS
$cshowList :: [PopPositionError] -> ShowS
show :: PopPositionError -> String
$cshow :: PopPositionError -> String
showsPrec :: Int -> PopPositionError -> ShowS
$cshowsPrec :: Int -> PopPositionError -> ShowS
Show)

-- | Errors from 'dropPosition'.
data DropPositionError =
  DropPositionStackEmpty
  -- ^ There is no previous position to drop.  No action was taken.
  deriving (DropPositionError -> DropPositionError -> Bool
(DropPositionError -> DropPositionError -> Bool)
-> (DropPositionError -> DropPositionError -> Bool)
-> Eq DropPositionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DropPositionError -> DropPositionError -> Bool
$c/= :: DropPositionError -> DropPositionError -> Bool
== :: DropPositionError -> DropPositionError -> Bool
$c== :: DropPositionError -> DropPositionError -> Bool
Eq, Int -> DropPositionError -> ShowS
[DropPositionError] -> ShowS
DropPositionError -> String
(Int -> DropPositionError -> ShowS)
-> (DropPositionError -> String)
-> ([DropPositionError] -> ShowS)
-> Show DropPositionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DropPositionError] -> ShowS
$cshowList :: [DropPositionError] -> ShowS
show :: DropPositionError -> String
$cshow :: DropPositionError -> String
showsPrec :: Int -> DropPositionError -> ShowS
$cshowsPrec :: Int -> DropPositionError -> ShowS
Show)

-- | Errors from 'modifyProperty'.
data ModifyPropertyError =
  ModifyPropertyCannotChangeType String String
  -- ^ The function attempted to change the property into another property;
  -- this is not allowed.  No change was made.  The two strings are renderings
  -- of the old and new property, respectively.
  deriving (ModifyPropertyError -> ModifyPropertyError -> Bool
(ModifyPropertyError -> ModifyPropertyError -> Bool)
-> (ModifyPropertyError -> ModifyPropertyError -> Bool)
-> Eq ModifyPropertyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModifyPropertyError -> ModifyPropertyError -> Bool
$c/= :: ModifyPropertyError -> ModifyPropertyError -> Bool
== :: ModifyPropertyError -> ModifyPropertyError -> Bool
$c== :: ModifyPropertyError -> ModifyPropertyError -> Bool
Eq, Int -> ModifyPropertyError -> ShowS
[ModifyPropertyError] -> ShowS
ModifyPropertyError -> String
(Int -> ModifyPropertyError -> ShowS)
-> (ModifyPropertyError -> String)
-> ([ModifyPropertyError] -> ShowS)
-> Show ModifyPropertyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModifyPropertyError] -> ShowS
$cshowList :: [ModifyPropertyError] -> ShowS
show :: ModifyPropertyError -> String
$cshow :: ModifyPropertyError -> String
showsPrec :: Int -> ModifyPropertyError -> ShowS
$cshowsPrec :: Int -> ModifyPropertyError -> ShowS
Show)

-- | Errors from 'modifyGameInfo'.
data ModifyGameInfoError =
  ModifyGameInfoCannotModifyRootInfo GameInfo GameInfo
  -- ^ The function illegally attempted to modify 'RootInfo' properties within
  -- the 'GameInfo'.  The old and attempted new records are returned,
  -- respectfully.  No changes were committed to the game info.
  deriving (ModifyGameInfoError -> ModifyGameInfoError -> Bool
(ModifyGameInfoError -> ModifyGameInfoError -> Bool)
-> (ModifyGameInfoError -> ModifyGameInfoError -> Bool)
-> Eq ModifyGameInfoError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModifyGameInfoError -> ModifyGameInfoError -> Bool
$c/= :: ModifyGameInfoError -> ModifyGameInfoError -> Bool
== :: ModifyGameInfoError -> ModifyGameInfoError -> Bool
$c== :: ModifyGameInfoError -> ModifyGameInfoError -> Bool
Eq, Int -> ModifyGameInfoError -> ShowS
[ModifyGameInfoError] -> ShowS
ModifyGameInfoError -> String
(Int -> ModifyGameInfoError -> ShowS)
-> (ModifyGameInfoError -> String)
-> ([ModifyGameInfoError] -> ShowS)
-> Show ModifyGameInfoError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModifyGameInfoError] -> ShowS
$cshowList :: [ModifyGameInfoError] -> ShowS
show :: ModifyGameInfoError -> String
$cshow :: ModifyGameInfoError -> String
showsPrec :: Int -> ModifyGameInfoError -> ShowS
$cshowsPrec :: Int -> ModifyGameInfoError -> ShowS
Show)

-- | Errors from calling 'deleteChildAt'.
data NodeDeleteError =
  NodeDeleteBadIndex
  -- ^ The node couldn't be deleted, because an invalid index was given.
  | NodeDeleteOnPathStack
    -- ^ The node couldn't be deleted, because it is on the path stack.
  deriving (NodeDeleteError -> NodeDeleteError -> Bool
(NodeDeleteError -> NodeDeleteError -> Bool)
-> (NodeDeleteError -> NodeDeleteError -> Bool)
-> Eq NodeDeleteError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeDeleteError -> NodeDeleteError -> Bool
$c/= :: NodeDeleteError -> NodeDeleteError -> Bool
== :: NodeDeleteError -> NodeDeleteError -> Bool
$c== :: NodeDeleteError -> NodeDeleteError -> Bool
Eq, Int -> NodeDeleteError -> ShowS
[NodeDeleteError] -> ShowS
NodeDeleteError -> String
(Int -> NodeDeleteError -> ShowS)
-> (NodeDeleteError -> String)
-> ([NodeDeleteError] -> ShowS)
-> Show NodeDeleteError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeDeleteError] -> ShowS
$cshowList :: [NodeDeleteError] -> ShowS
show :: NodeDeleteError -> String
$cshow :: NodeDeleteError -> String
showsPrec :: Int -> NodeDeleteError -> ShowS
$cshowsPrec :: Int -> NodeDeleteError -> ShowS
Show)

-- | Like 'goUp', but throws 'NavigationCouldNotMove' if at the root of the
-- tree.
goUpOrThrow :: (MonadGo m, MonadError GoError m) => m ()
goUpOrThrow :: m ()
goUpOrThrow = m Bool
forall (go :: * -> *). MonadGo go => go Bool
goUp m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool
False -> GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ()) -> GoError -> m ()
forall a b. (a -> b) -> a -> b
$ NavigationError -> GoError
GoNavigationError NavigationError
NavigationCouldNotMove

-- | Like 'goDown', but throws 'NavigationCouldNotMove' if the requested child
-- does not exist.
goDownOrThrow :: (MonadGo m, MonadError GoError m) => Int -> m ()
goDownOrThrow :: Int -> m ()
goDownOrThrow Int
index = Int -> m Bool
forall (go :: * -> *). MonadGo go => Int -> go Bool
goDown Int
index m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool
False -> GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ()) -> GoError -> m ()
forall a b. (a -> b) -> a -> b
$ NavigationError -> GoError
GoNavigationError NavigationError
NavigationCouldNotMove

-- | Like 'goLeft', but throws 'NavigationCouldNotMove' if there is no left
-- sibling to move to.
goLeftOrThrow :: (MonadGo m, MonadError GoError m) => m ()
goLeftOrThrow :: m ()
goLeftOrThrow = m Bool
forall (go :: * -> *). MonadGo go => go Bool
goLeft m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool
False -> GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ()) -> GoError -> m ()
forall a b. (a -> b) -> a -> b
$ NavigationError -> GoError
GoNavigationError NavigationError
NavigationCouldNotMove

-- | Like 'goRight', but throws 'NavigationCouldNotMove' if there is no right
-- sibling to move to.
goRightOrThrow :: (MonadGo m, MonadError GoError m) => m ()
goRightOrThrow :: m ()
goRightOrThrow = m Bool
forall (go :: * -> *). MonadGo go => go Bool
goRight m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool
False -> GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ()) -> GoError -> m ()
forall a b. (a -> b) -> a -> b
$ NavigationError -> GoError
GoNavigationError NavigationError
NavigationCouldNotMove

-- | Same as 'popPosition', but throws errors rather than returning them.
popPositionOrThrow :: (MonadGo m, MonadError GoError m) => m ()
popPositionOrThrow :: m ()
popPositionOrThrow =
  m (Either PopPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either PopPositionError ())
popPosition m (Either PopPositionError ())
-> (Either PopPositionError () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (PopPositionError -> m ())
-> (() -> m ()) -> Either PopPositionError () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ())
-> (PopPositionError -> GoError) -> PopPositionError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PopPositionError -> GoError
GoPopPositionError) () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Same as 'dropPosition', but throws errors rather than returning them.
dropPositionOrThrow :: (MonadGo m, MonadError GoError m) => m ()
dropPositionOrThrow :: m ()
dropPositionOrThrow =
  m (Either DropPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either DropPositionError ())
dropPosition m (Either DropPositionError ())
-> (Either DropPositionError () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (DropPositionError -> m ())
-> (() -> m ()) -> Either DropPositionError () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ())
-> (DropPositionError -> GoError) -> DropPositionError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DropPositionError -> GoError
GoDropPositionError) () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Same as 'modifyProperty', but throws errors rather than returning them.
modifyPropertyOrThrow :: (MonadGo m, MonadError GoError m, Descriptor d)
                      => d
                      -> (Maybe Property -> Maybe Property)
                      -> m ()
modifyPropertyOrThrow :: d -> (Maybe Property -> Maybe Property) -> m ()
modifyPropertyOrThrow d
descriptor Maybe Property -> Maybe Property
fn =
  d
-> (Maybe Property -> Maybe Property)
-> m (Either ModifyPropertyError ())
forall (go :: * -> *) d.
(MonadGo go, Descriptor d) =>
d
-> (Maybe Property -> Maybe Property)
-> go (Either ModifyPropertyError ())
modifyProperty d
descriptor Maybe Property -> Maybe Property
fn m (Either ModifyPropertyError ())
-> (Either ModifyPropertyError () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (ModifyPropertyError -> m ())
-> (() -> m ()) -> Either ModifyPropertyError () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ())
-> (ModifyPropertyError -> GoError) -> ModifyPropertyError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModifyPropertyError -> GoError
GoModifyPropertyError) () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Same as 'modifyGameInfo', but throws errors rather than returning them.
modifyGameInfoOrThrow :: (MonadGo m, MonadError GoError m)
                      => (GameInfo -> GameInfo)
                      -> m (GameInfo, GameInfo)
modifyGameInfoOrThrow :: (GameInfo -> GameInfo) -> m (GameInfo, GameInfo)
modifyGameInfoOrThrow GameInfo -> GameInfo
fn =
  (GameInfo -> GameInfo)
-> m (Either ModifyGameInfoError (GameInfo, GameInfo))
forall (go :: * -> *).
MonadGo go =>
(GameInfo -> GameInfo)
-> go (Either ModifyGameInfoError (GameInfo, GameInfo))
modifyGameInfo GameInfo -> GameInfo
fn m (Either ModifyGameInfoError (GameInfo, GameInfo))
-> (Either ModifyGameInfoError (GameInfo, GameInfo)
    -> m (GameInfo, GameInfo))
-> m (GameInfo, GameInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (ModifyGameInfoError -> m (GameInfo, GameInfo))
-> ((GameInfo, GameInfo) -> m (GameInfo, GameInfo))
-> Either ModifyGameInfoError (GameInfo, GameInfo)
-> m (GameInfo, GameInfo)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GoError -> m (GameInfo, GameInfo)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m (GameInfo, GameInfo))
-> (ModifyGameInfoError -> GoError)
-> ModifyGameInfoError
-> m (GameInfo, GameInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModifyGameInfoError -> GoError
GoModifyGameInfoError) (GameInfo, GameInfo) -> m (GameInfo, GameInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Same as 'deleteChildAt', but throws errors rather than returning them.
deleteChildAtOrThrow :: (MonadGo m, MonadError GoError m) => Int -> m ()
deleteChildAtOrThrow :: Int -> m ()
deleteChildAtOrThrow Int
index =
  Int -> m (Either NodeDeleteError ())
forall (go :: * -> *).
MonadGo go =>
Int -> go (Either NodeDeleteError ())
deleteChildAt Int
index m (Either NodeDeleteError ())
-> (Either NodeDeleteError () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (NodeDeleteError -> m ())
-> (() -> m ()) -> Either NodeDeleteError () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (GoError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GoError -> m ())
-> (NodeDeleteError -> GoError) -> NodeDeleteError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeDeleteError -> GoError
GoNodeDeleteError) () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | The standard monad transformer for 'MonadGo'.
newtype GoT m a = GoT { GoT m a -> StateT (GoState (GoT m)) m a
goState :: StateT (GoState (GoT m)) m a }

-- | The standard monad for 'MonadGo'.
type GoM = GoT Identity

instance Monad m => Functor (GoT m) where
  fmap :: (a -> b) -> GoT m a -> GoT m b
fmap = (a -> b) -> GoT m a -> GoT m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Monad m => Applicative (GoT m) where
  pure :: a -> GoT m a
pure = a -> GoT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: GoT m (a -> b) -> GoT m a -> GoT m b
(<*>) = GoT m (a -> b) -> GoT m a -> GoT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (GoT m) where
  return :: a -> GoT m a
return a
x = StateT (GoState (GoT m)) m a -> GoT m a
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m a -> GoT m a)
-> StateT (GoState (GoT m)) m a -> GoT m a
forall a b. (a -> b) -> a -> b
$ a -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  GoT m a
m >>= :: GoT m a -> (a -> GoT m b) -> GoT m b
>>= a -> GoT m b
f = StateT (GoState (GoT m)) m b -> GoT m b
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m b -> GoT m b)
-> StateT (GoState (GoT m)) m b -> GoT m b
forall a b. (a -> b) -> a -> b
$ GoT m b -> StateT (GoState (GoT m)) m b
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState (GoT m b -> StateT (GoState (GoT m)) m b)
-> (a -> GoT m b) -> a -> StateT (GoState (GoT m)) m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> GoT m b
f (a -> StateT (GoState (GoT m)) m b)
-> StateT (GoState (GoT m)) m a -> StateT (GoState (GoT m)) m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GoT m a -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState GoT m a
m

instance MonadFail m => MonadFail (GoT m) where
  fail :: String -> GoT m a
fail = StateT (GoState (GoT m)) m a -> GoT m a
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m a -> GoT m a)
-> (String -> StateT (GoState (GoT m)) m a) -> String -> GoT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance MonadTrans GoT where
  lift :: m a -> GoT m a
lift = StateT (GoState (GoT m)) m a -> GoT m a
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m a -> GoT m a)
-> (m a -> StateT (GoState (GoT m)) m a) -> m a -> GoT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT (GoState (GoT m)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadIO m => MonadIO (GoT m) where
  liftIO :: IO a -> GoT m a
liftIO = m a -> GoT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> GoT m a) -> (IO a -> m a) -> IO a -> GoT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadState s m => MonadState s (GoT m) where
  get :: GoT m s
get = m s -> GoT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> GoT m ()
put = m () -> GoT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> GoT m ()) -> (s -> m ()) -> s -> GoT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance MonadWriter w m => MonadWriter w (GoT m) where
  writer :: (a, w) -> GoT m a
writer = m a -> GoT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> GoT m a) -> ((a, w) -> m a) -> (a, w) -> GoT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer
  tell :: w -> GoT m ()
tell = m () -> GoT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> GoT m ()) -> (w -> m ()) -> w -> GoT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: GoT m a -> GoT m (a, w)
listen = StateT (GoState (GoT m)) m (a, w) -> GoT m (a, w)
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m (a, w) -> GoT m (a, w))
-> (GoT m a -> StateT (GoState (GoT m)) m (a, w))
-> GoT m a
-> GoT m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (GoState (GoT m)) m a -> StateT (GoState (GoT m)) m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (StateT (GoState (GoT m)) m a -> StateT (GoState (GoT m)) m (a, w))
-> (GoT m a -> StateT (GoState (GoT m)) m a)
-> GoT m a
-> StateT (GoState (GoT m)) m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GoT m a -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState
  pass :: GoT m (a, w -> w) -> GoT m a
pass = StateT (GoState (GoT m)) m a -> GoT m a
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m a -> GoT m a)
-> (GoT m (a, w -> w) -> StateT (GoState (GoT m)) m a)
-> GoT m (a, w -> w)
-> GoT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (GoState (GoT m)) m (a, w -> w)
-> StateT (GoState (GoT m)) m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (StateT (GoState (GoT m)) m (a, w -> w)
 -> StateT (GoState (GoT m)) m a)
-> (GoT m (a, w -> w) -> StateT (GoState (GoT m)) m (a, w -> w))
-> GoT m (a, w -> w)
-> StateT (GoState (GoT m)) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GoT m (a, w -> w) -> StateT (GoState (GoT m)) m (a, w -> w)
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState

instance MonadError e m => MonadError e (GoT m) where
  throwError :: e -> GoT m a
throwError = m a -> GoT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> GoT m a) -> (e -> m a) -> e -> GoT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: GoT m a -> (e -> GoT m a) -> GoT m a
catchError GoT m a
action e -> GoT m a
handler =
    -- action :: GoT m a
    -- handler :: e -> GoT m a
    -- Need to call catchError :: StateT (GoState (GoT m)) m a -> (e -> StateT ...) -> StateT ...
    StateT (GoState (GoT m)) m a -> GoT m a
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m a -> GoT m a)
-> StateT (GoState (GoT m)) m a -> GoT m a
forall a b. (a -> b) -> a -> b
$ StateT (GoState (GoT m)) m a
-> (e -> StateT (GoState (GoT m)) m a)
-> StateT (GoState (GoT m)) m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (GoT m a -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState GoT m a
action) (GoT m a -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState (GoT m a -> StateT (GoState (GoT m)) m a)
-> (e -> GoT m a) -> e -> StateT (GoState (GoT m)) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> GoT m a
handler)

-- | Executes a Go monad transformer on a cursor, returning in the underlying
-- monad a tuple that contains the resulting value and the final cursor.
runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor)
runGoT :: GoT m a -> Cursor -> m (a, Cursor)
runGoT GoT m a
go Cursor
cursor = do
  (a
value, GoState (GoT m)
state) <- StateT (GoState (GoT m)) m a
-> GoState (GoT m) -> m (a, GoState (GoT m))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (GoT m a -> StateT (GoState (GoT m)) m a
forall (m :: * -> *) a. GoT m a -> StateT (GoState (GoT m)) m a
goState GoT m a
go) (Cursor -> GoState (GoT m)
forall (m :: * -> *). Cursor -> GoState m
initialState Cursor
cursor)
  (a, Cursor) -> m (a, Cursor)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
value, GoState (GoT m) -> Cursor
forall (go :: * -> *). GoState go -> Cursor
stateCursor GoState (GoT m)
state)

-- | Executes a Go monad transformer on a cursor, returning in the underlying
-- monad the value in the transformer.
evalGoT :: Monad m => GoT m a -> Cursor -> m a
evalGoT :: GoT m a -> Cursor -> m a
evalGoT GoT m a
go Cursor
cursor = ((a, Cursor) -> a) -> m (a, Cursor) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, Cursor) -> a
forall a b. (a, b) -> a
fst (m (a, Cursor) -> m a) -> m (a, Cursor) -> m a
forall a b. (a -> b) -> a -> b
$ GoT m a -> Cursor -> m (a, Cursor)
forall (m :: * -> *) a.
Monad m =>
GoT m a -> Cursor -> m (a, Cursor)
runGoT GoT m a
go Cursor
cursor

-- | Executes a Go monad transformer on a cursor, returning in the underlying
-- monad the final cursor.
execGoT :: Monad m => GoT m a -> Cursor -> m Cursor
execGoT :: GoT m a -> Cursor -> m Cursor
execGoT GoT m a
go Cursor
cursor = ((a, Cursor) -> Cursor) -> m (a, Cursor) -> m Cursor
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, Cursor) -> Cursor
forall a b. (a, b) -> b
snd (m (a, Cursor) -> m Cursor) -> m (a, Cursor) -> m Cursor
forall a b. (a -> b) -> a -> b
$ GoT m a -> Cursor -> m (a, Cursor)
forall (m :: * -> *) a.
Monad m =>
GoT m a -> Cursor -> m (a, Cursor)
runGoT GoT m a
go Cursor
cursor

-- | Runs a Go monad on a cursor.  See 'runGoT'.
runGo :: GoM a -> Cursor -> (a, Cursor)
runGo :: GoM a -> Cursor -> (a, Cursor)
runGo GoM a
go = Identity (a, Cursor) -> (a, Cursor)
forall a. Identity a -> a
runIdentity (Identity (a, Cursor) -> (a, Cursor))
-> (Cursor -> Identity (a, Cursor)) -> Cursor -> (a, Cursor)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GoM a -> Cursor -> Identity (a, Cursor)
forall (m :: * -> *) a.
Monad m =>
GoT m a -> Cursor -> m (a, Cursor)
runGoT GoM a
go

-- | Runs a Go monad on a cursor and returns the value in the monad.
evalGo :: GoM a -> Cursor -> a
evalGo :: GoM a -> Cursor -> a
evalGo GoM a
m Cursor
cursor = (a, Cursor) -> a
forall a b. (a, b) -> a
fst ((a, Cursor) -> a) -> (a, Cursor) -> a
forall a b. (a -> b) -> a -> b
$ GoM a -> Cursor -> (a, Cursor)
forall a. GoM a -> Cursor -> (a, Cursor)
runGo GoM a
m Cursor
cursor

-- | Runs a Go monad on a cursor and returns the final cursor.
execGo :: GoM a -> Cursor -> Cursor
execGo :: GoM a -> Cursor -> Cursor
execGo GoM a
m Cursor
cursor = (a, Cursor) -> Cursor
forall a b. (a, b) -> b
snd ((a, Cursor) -> Cursor) -> (a, Cursor) -> Cursor
forall a b. (a -> b) -> a -> b
$ GoM a -> Cursor -> (a, Cursor)
forall a. GoM a -> Cursor -> (a, Cursor)
runGo GoM a
m Cursor
cursor

getState :: Monad m => GoT m (GoState (GoT m))
getState :: GoT m (GoState (GoT m))
getState = StateT (GoState (GoT m)) m (GoState (GoT m))
-> GoT m (GoState (GoT m))
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT StateT (GoState (GoT m)) m (GoState (GoT m))
forall s (m :: * -> *). MonadState s m => m s
State.get

putState :: Monad m => GoState (GoT m) -> GoT m ()
putState :: GoState (GoT m) -> GoT m ()
putState = StateT (GoState (GoT m)) m () -> GoT m ()
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m () -> GoT m ())
-> (GoState (GoT m) -> StateT (GoState (GoT m)) m ())
-> GoState (GoT m)
-> GoT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GoState (GoT m) -> StateT (GoState (GoT m)) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put

modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState :: (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState = StateT (GoState (GoT m)) m () -> GoT m ()
forall (m :: * -> *) a. StateT (GoState (GoT m)) m a -> GoT m a
GoT (StateT (GoState (GoT m)) m () -> GoT m ())
-> ((GoState (GoT m) -> GoState (GoT m))
    -> StateT (GoState (GoT m)) m ())
-> (GoState (GoT m) -> GoState (GoT m))
-> GoT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GoState (GoT m) -> GoState (GoT m))
-> StateT (GoState (GoT m)) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify

instance Monad m => MonadGo (GoT m) where
  getCursor :: GoT m Cursor
getCursor = (GoState (GoT m) -> Cursor)
-> GoT m (GoState (GoT m)) -> GoT m Cursor
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM GoState (GoT m) -> Cursor
forall (go :: * -> *). GoState go -> Cursor
stateCursor GoT m (GoState (GoT m))
forall (m :: * -> *). Monad m => GoT m (GoState (GoT m))
getState

  -- TODO For goUp and goDown, optimize by seeing checking if (head $ head
  -- pathStack) is the step we're taking, and if so, dropping it from the list
  -- rather than pushing a fresh step.
  goUp :: GoT m Bool
goUp = do
    Int
index <- (Cursor -> Int) -> GoT m Cursor -> GoT m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Cursor -> Int
cursorChildIndex GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    (PathStack -> PathStack) -> GoT m Bool
forall (m :: * -> *).
Monad m =>
(PathStack -> PathStack) -> GoT m Bool
goUp' ((PathStack -> PathStack) -> GoT m Bool)
-> (PathStack -> PathStack) -> GoT m Bool
forall a b. (a -> b) -> a -> b
$ \PathStack
pathStack -> case PathStack
pathStack of
      [] -> PathStack
pathStack
      [Step]
path:PathStack
paths -> (Int -> Step
GoDown Int
indexStep -> [Step] -> [Step]
forall a. a -> [a] -> [a]
:[Step]
path)[Step] -> PathStack -> PathStack
forall a. a -> [a] -> [a]
:PathStack
paths

  goDown :: Int -> GoT m Bool
goDown Int
index = Int -> (PathStack -> PathStack) -> GoT m Bool
forall (m :: * -> *).
Monad m =>
Int -> (PathStack -> PathStack) -> GoT m Bool
goDown' Int
index ((PathStack -> PathStack) -> GoT m Bool)
-> (PathStack -> PathStack) -> GoT m Bool
forall a b. (a -> b) -> a -> b
$ \PathStack
pathStack -> case PathStack
pathStack of
    [] -> PathStack
pathStack
    [Step]
path:PathStack
paths -> (Int -> Step
GoUp Int
indexStep -> [Step] -> [Step]
forall a. a -> [a] -> [a]
:[Step]
path)[Step] -> PathStack -> PathStack
forall a. a -> [a] -> [a]
:PathStack
paths

  goLeft :: GoT m Bool
goLeft = do
    Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    case (Cursor -> Maybe Cursor
cursorParent Cursor
cursor, Cursor -> Int
cursorChildIndex Cursor
cursor) of
      (Maybe Cursor
Nothing, Int
_) -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      (Just Cursor
_, Int
0) -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      (Just Cursor
_, Int
n) -> GoT m Bool
forall (go :: * -> *). MonadGo go => go Bool
goUp GoT m Bool -> (Bool -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Int -> GoT m Bool
forall (go :: * -> *). MonadGo go => Int -> go Bool
goDown (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) GoT m Bool -> (Bool -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Bool
False -> String -> GoT m Bool
forall a. HasCallStack => String -> a
error String
"GoT.goLeft: Internal error, could not go down."
        Bool
False -> String -> GoT m Bool
forall a. HasCallStack => String -> a
error String
"GoT.goLeft: Internal error, could not go up."

  goRight :: GoT m Bool
goRight = do
    Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    case (Cursor -> Maybe Cursor
cursorParent Cursor
cursor, Cursor -> Int
cursorChildIndex Cursor
cursor) of
      (Maybe Cursor
Nothing, Int
_) -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      (Just Cursor
parent, Int
n) | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Cursor -> Int
cursorChildCount Cursor
parent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      (Just Cursor
_, Int
n) -> GoT m Bool
forall (go :: * -> *). MonadGo go => go Bool
goUp GoT m Bool -> (Bool -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Int -> GoT m Bool
forall (go :: * -> *). MonadGo go => Int -> go Bool
goDown (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GoT m Bool -> (Bool -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Bool
False -> String -> GoT m Bool
forall a. HasCallStack => String -> a
error String
"GoT.goRight: Internal error, could not go down."
        Bool
False -> String -> GoT m Bool
forall a. HasCallStack => String -> a
error String
"GoT.goRight: Internal error, could not go up."

  goToRoot :: GoT m ()
goToRoot = GoT m Bool -> GoT m () -> GoT m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whileM GoT m Bool
forall (go :: * -> *). MonadGo go => go Bool
goUp (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$ () -> GoT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  goToGameInfoNode :: Bool -> GoT m Bool
goToGameInfoNode Bool
goToRootIfNotFound = GoT m ()
forall (go :: * -> *). MonadGo go => go ()
pushPosition GoT m () -> GoT m Bool -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GoT m Bool
findGameInfoNode
    where findGameInfoNode :: GoT m Bool
findGameInfoNode = do
            Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
            if Cursor -> Bool
hasGameInfo Cursor
cursor
              then GoT m (Either DropPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either DropPositionError ())
dropPosition GoT m (Either DropPositionError ())
-> (Either DropPositionError () -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                     Right () -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                     Left DropPositionError
DropPositionStackEmpty -> GoT m Bool
forall a. a
errorDropStackEmpty
              else if Maybe Cursor -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Cursor -> Bool) -> Maybe Cursor -> Bool
forall a b. (a -> b) -> a -> b
$ Cursor -> Maybe Cursor
cursorParent Cursor
cursor
                   then if Bool
goToRootIfNotFound
                        then GoT m (Either DropPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either DropPositionError ())
dropPosition GoT m (Either DropPositionError ())
-> (Either DropPositionError () -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                               Right () -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                               Left DropPositionError
DropPositionStackEmpty -> GoT m Bool
forall a. a
errorDropStackEmpty
                        else GoT m (Either PopPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either PopPositionError ())
popPosition GoT m (Either PopPositionError ())
-> (Either PopPositionError () -> GoT m Bool) -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                               Right () -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                               Left PopPositionError
PopPositionStackEmpty -> GoT m Bool
forall a. a
errorPopStackEmpty
                               Left PopPositionError
PopPositionCannotRetraceSteps -> GoT m Bool
forall a. a
errorPopCannotRetrace
                   else GoT m Bool
forall (go :: * -> *). MonadGo go => go Bool
goUp GoT m Bool -> GoT m Bool -> GoT m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GoT m Bool
findGameInfoNode
          hasGameInfo :: Cursor -> Bool
hasGameInfo Cursor
cursor = Node -> Bool
internalIsGameInfoNode (Node -> Bool) -> Node -> Bool
forall a b. (a -> b) -> a -> b
$ Cursor -> Node
cursorNode Cursor
cursor
          errorDropStackEmpty :: a
errorDropStackEmpty =
            String -> a
forall a. HasCallStack => String -> a
error String
"GoT.goToGameInfoNode: Internal error, DropPositionStackEmpty."
          errorPopStackEmpty :: a
errorPopStackEmpty =
            String -> a
forall a. HasCallStack => String -> a
error String
"GoT.goToGameInfoNode: Internal error, PopPositionStackEmpty."
          errorPopCannotRetrace :: a
errorPopCannotRetrace =
            String -> a
forall a. HasCallStack => String -> a
error String
"GoT.goToGameInfoNode: Internal error, PopPositionCannotRetraceSteps."

  pushPosition :: GoT m ()
pushPosition = (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall (m :: * -> *).
Monad m =>
(GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState ((GoState (GoT m) -> GoState (GoT m)) -> GoT m ())
-> (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \GoState (GoT m)
state ->
    GoState (GoT m)
state { statePathStack :: PathStack
statePathStack = [][Step] -> PathStack -> PathStack
forall a. a -> [a] -> [a]
:GoState (GoT m) -> PathStack
forall (go :: * -> *). GoState go -> PathStack
statePathStack GoState (GoT m)
state }

  popPosition :: GoT m (Either PopPositionError ())
popPosition = do
    GoT m PathStack
forall (m :: * -> *). Monad m => GoT m PathStack
getPathStack GoT m PathStack
-> (PathStack -> GoT m (Either PopPositionError ()))
-> GoT m (Either PopPositionError ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> Either PopPositionError () -> GoT m (Either PopPositionError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PopPositionError () -> GoT m (Either PopPositionError ()))
-> Either PopPositionError () -> GoT m (Either PopPositionError ())
forall a b. (a -> b) -> a -> b
$ PopPositionError -> Either PopPositionError ()
forall a b. a -> Either a b
Left PopPositionError
PopPositionStackEmpty
      PathStack
_ -> do
        -- Drop each step in the top list of the path stack one at a time, until the
        -- top list is empty.
        Maybe PopPositionError
maybeRetraceErrorResult <- GoT m (Either (Maybe PopPositionError) Step)
-> (Step -> GoT m (Maybe (Maybe PopPositionError)))
-> GoT m (Maybe PopPositionError)
forall (m :: * -> *) r a.
Monad m =>
m (Either r a) -> (a -> m (Maybe r)) -> m r
whileM''
          (do ~([Step]
path:PathStack
_) <- GoT m PathStack
forall (m :: * -> *). Monad m => GoT m PathStack
getPathStack  -- TODO Don't use irrefutable pattern.
              Either (Maybe PopPositionError) Step
-> GoT m (Either (Maybe PopPositionError) Step)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe PopPositionError) Step
 -> GoT m (Either (Maybe PopPositionError) Step))
-> Either (Maybe PopPositionError) Step
-> GoT m (Either (Maybe PopPositionError) Step)
forall a b. (a -> b) -> a -> b
$ if [Step] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Step]
path then Maybe PopPositionError -> Either (Maybe PopPositionError) Step
forall a b. a -> Either a b
Left Maybe PopPositionError
forall a. Maybe a
Nothing else Step -> Either (Maybe PopPositionError) Step
forall a b. b -> Either a b
Right (Step -> Either (Maybe PopPositionError) Step)
-> Step -> Either (Maybe PopPositionError) Step
forall a b. (a -> b) -> a -> b
$ [Step] -> Step
forall a. [a] -> a
head [Step]
path)
          (\Step
step -> do
            Bool
ok <- Step -> (PathStack -> PathStack) -> GoT m Bool
forall (m :: * -> *).
Monad m =>
Step -> (PathStack -> PathStack) -> GoT m Bool
takeStepM Step
step ((PathStack -> PathStack) -> GoT m Bool)
-> (PathStack -> PathStack) -> GoT m Bool
forall a b. (a -> b) -> a -> b
$ \((Step
_:[Step]
steps):PathStack
paths) -> [Step]
steps[Step] -> PathStack -> PathStack
forall a. a -> [a] -> [a]
:PathStack
paths
            Maybe (Maybe PopPositionError)
-> GoT m (Maybe (Maybe PopPositionError))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe PopPositionError)
 -> GoT m (Maybe (Maybe PopPositionError)))
-> Maybe (Maybe PopPositionError)
-> GoT m (Maybe (Maybe PopPositionError))
forall a b. (a -> b) -> a -> b
$ if Bool
ok then Maybe (Maybe PopPositionError)
forall a. Maybe a
Nothing else Maybe PopPositionError -> Maybe (Maybe PopPositionError)
forall a. a -> Maybe a
Just (Maybe PopPositionError -> Maybe (Maybe PopPositionError))
-> Maybe PopPositionError -> Maybe (Maybe PopPositionError)
forall a b. (a -> b) -> a -> b
$ PopPositionError -> Maybe PopPositionError
forall a. a -> Maybe a
Just PopPositionError
PopPositionCannotRetraceSteps)

        case Maybe PopPositionError
maybeRetraceErrorResult of
          Just PopPositionError
err -> Either PopPositionError () -> GoT m (Either PopPositionError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PopPositionError () -> GoT m (Either PopPositionError ()))
-> Either PopPositionError () -> GoT m (Either PopPositionError ())
forall a b. (a -> b) -> a -> b
$ PopPositionError -> Either PopPositionError ()
forall a b. a -> Either a b
Left PopPositionError
err
          Maybe PopPositionError
Nothing -> do
            -- Finally, drop the empty top of the path stack.
            (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall (m :: * -> *).
Monad m =>
(GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState ((GoState (GoT m) -> GoState (GoT m)) -> GoT m ())
-> (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \GoState (GoT m)
state -> case GoState (GoT m) -> PathStack
forall (go :: * -> *). GoState go -> PathStack
statePathStack GoState (GoT m)
state of
              []:PathStack
rest -> GoState (GoT m)
state { statePathStack :: PathStack
statePathStack = PathStack
rest }
              PathStack
_ -> String -> GoState (GoT m)
forall a. HasCallStack => String -> a
error String
"popPosition: Internal failure, top of path stack is not empty."

            Either PopPositionError () -> GoT m (Either PopPositionError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PopPositionError () -> GoT m (Either PopPositionError ()))
-> Either PopPositionError () -> GoT m (Either PopPositionError ())
forall a b. (a -> b) -> a -> b
$ () -> Either PopPositionError ()
forall a b. b -> Either a b
Right ()

  dropPosition :: GoT m (Either DropPositionError ())
dropPosition = do
    GoState (GoT m)
state <- GoT m (GoState (GoT m))
forall (m :: * -> *). Monad m => GoT m (GoState (GoT m))
getState
    -- If there are >=2 positions on the path stack, then we can't simply drop
    -- the moves that will return us to the top-of-stack position, because they
    -- may still be needed to return to the second-on-stack position by a
    -- following popPosition.
    case GoState (GoT m) -> PathStack
forall (go :: * -> *). GoState go -> PathStack
statePathStack GoState (GoT m)
state of
      [Step]
x:[Step]
y:PathStack
xs -> do GoState (GoT m) -> GoT m ()
forall (m :: * -> *). Monad m => GoState (GoT m) -> GoT m ()
putState (GoState (GoT m) -> GoT m ()) -> GoState (GoT m) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ GoState (GoT m)
state { statePathStack :: PathStack
statePathStack = ([Step]
x [Step] -> [Step] -> [Step]
forall a. [a] -> [a] -> [a]
++ [Step]
y)[Step] -> PathStack -> PathStack
forall a. a -> [a] -> [a]
:PathStack
xs }
                   Either DropPositionError () -> GoT m (Either DropPositionError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DropPositionError ()
 -> GoT m (Either DropPositionError ()))
-> Either DropPositionError ()
-> GoT m (Either DropPositionError ())
forall a b. (a -> b) -> a -> b
$ () -> Either DropPositionError ()
forall a b. b -> Either a b
Right ()
      [[Step]
_] -> do GoState (GoT m) -> GoT m ()
forall (m :: * -> *). Monad m => GoState (GoT m) -> GoT m ()
putState (GoState (GoT m) -> GoT m ()) -> GoState (GoT m) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ GoState (GoT m)
state { statePathStack :: PathStack
statePathStack = [] }
                Either DropPositionError () -> GoT m (Either DropPositionError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DropPositionError ()
 -> GoT m (Either DropPositionError ()))
-> Either DropPositionError ()
-> GoT m (Either DropPositionError ())
forall a b. (a -> b) -> a -> b
$ () -> Either DropPositionError ()
forall a b. b -> Either a b
Right ()
      [] -> Either DropPositionError () -> GoT m (Either DropPositionError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DropPositionError ()
 -> GoT m (Either DropPositionError ()))
-> Either DropPositionError ()
-> GoT m (Either DropPositionError ())
forall a b. (a -> b) -> a -> b
$ DropPositionError -> Either DropPositionError ()
forall a b. a -> Either a b
Left DropPositionError
DropPositionStackEmpty

  modifyProperties :: ([Property] -> [Property]) -> GoT m ()
modifyProperties [Property] -> [Property]
fn = do
    Cursor
oldCursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    let oldProperties :: [Property]
oldProperties = Cursor -> [Property]
cursorProperties Cursor
oldCursor
        newProperties :: [Property]
newProperties = [Property] -> [Property]
fn [Property]
oldProperties
    (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall (m :: * -> *).
Monad m =>
(GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState ((GoState (GoT m) -> GoState (GoT m)) -> GoT m ())
-> (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \GoState (GoT m)
state ->
      GoState (GoT m)
state { stateCursor :: Cursor
stateCursor = (Node -> Node) -> Cursor -> Cursor
cursorModifyNode
                            (\Node
node -> Node
node { nodeProperties :: [Property]
nodeProperties = [Property]
newProperties })
                            Cursor
oldCursor
            }
    Bool -> GoT m () -> GoT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Property -> Property -> Ordering) -> [Property] -> [Property]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Property -> String) -> Property -> Property -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Property -> String
forall a. Descriptor a => a -> String
propertyName) [Property]
newProperties [Property] -> [Property] -> Bool
forall a. Eq a => a -> a -> Bool
/=
          (Property -> Property -> Ordering) -> [Property] -> [Property]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Property -> String) -> Property -> Property -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Property -> String
forall a. Descriptor a => a -> String
propertyName) [Property]
oldProperties) (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$
      Event (GoT m) (PropertiesModifiedHandler (GoT m))
-> (PropertiesModifiedHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (PropertiesModifiedHandler (GoT m))
forall (go :: * -> *). Event go (PropertiesModifiedHandler go)
propertiesModifiedEvent (\PropertiesModifiedHandler (GoT m)
f -> PropertiesModifiedHandler (GoT m)
f [Property]
oldProperties [Property]
newProperties)

    -- The current game info changes when modifying game info properties on the
    -- current node.  I think comparing game info properties should be faster
    -- than comparing 'GameInfo's.
    let filterToGameInfo :: [Property] -> [Property]
filterToGameInfo = [Property] -> [Property]
forall a. Eq a => [a] -> [a]
nub ([Property] -> [Property])
-> ([Property] -> [Property]) -> [Property] -> [Property]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Property -> Bool) -> [Property] -> [Property]
forall a. (a -> Bool) -> [a] -> [a]
filter ((PropertyType
GameInfoProperty PropertyType -> PropertyType -> Bool
forall a. Eq a => a -> a -> Bool
==) (PropertyType -> Bool)
-> (Property -> PropertyType) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType)
        oldGameInfo :: [Property]
oldGameInfo = [Property] -> [Property]
filterToGameInfo [Property]
oldProperties
        newGameInfo :: [Property]
newGameInfo = [Property] -> [Property]
filterToGameInfo [Property]
newProperties
    Bool -> GoT m () -> GoT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Property]
newGameInfo [Property] -> [Property] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Property]
oldGameInfo) (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$ do
      Cursor
newCursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
      Event (GoT m) (GameInfoChangedHandler (GoT m))
-> (GameInfoChangedHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (GameInfoChangedHandler (GoT m))
forall (go :: * -> *). Event go (GameInfoChangedHandler go)
gameInfoChangedEvent (\GameInfoChangedHandler (GoT m)
f -> GameInfoChangedHandler (GoT m)
f (BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
oldCursor)
                                         (BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
newCursor))

  getProperty :: d -> GoT m (Maybe Property)
getProperty d
descriptor = (Property -> Bool) -> [Property] -> Maybe Property
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (d -> Property -> Bool
forall a. Descriptor a => a -> Property -> Bool
propertyPredicate d
descriptor) ([Property] -> Maybe Property)
-> GoT m [Property] -> GoT m (Maybe Property)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GoT m [Property]
forall (go :: * -> *). MonadGo go => go [Property]
getProperties

  modifyProperty :: d
-> (Maybe Property -> Maybe Property)
-> GoT m (Either ModifyPropertyError ())
modifyProperty d
descriptor Maybe Property -> Maybe Property
fn = do
    Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    let node :: Node
node = Cursor -> Node
cursorNode Cursor
cursor
        old :: Maybe Property
old = d -> Node -> Maybe Property
forall a. Descriptor a => a -> Node -> Maybe Property
findProperty d
descriptor Node
node
        new :: Maybe Property
new = Maybe Property -> Maybe Property
fn Maybe Property
old
    if (Bool -> (Property -> Bool) -> Maybe Property -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool) -> (Property -> Bool) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Property -> Bool
forall a. Descriptor a => a -> Property -> Bool
propertyPredicate d
descriptor) Maybe Property
new)
      then Either ModifyPropertyError ()
-> GoT m (Either ModifyPropertyError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModifyPropertyError ()
 -> GoT m (Either ModifyPropertyError ()))
-> Either ModifyPropertyError ()
-> GoT m (Either ModifyPropertyError ())
forall a b. (a -> b) -> a -> b
$ ModifyPropertyError -> Either ModifyPropertyError ()
forall a b. a -> Either a b
Left (ModifyPropertyError -> Either ModifyPropertyError ())
-> ModifyPropertyError -> Either ModifyPropertyError ()
forall a b. (a -> b) -> a -> b
$ String -> String -> ModifyPropertyError
ModifyPropertyCannotChangeType (Maybe Property -> String
forall a. Show a => a -> String
show Maybe Property
old) (Maybe Property -> String
forall a. Show a => a -> String
show Maybe Property
new)
      else do
        case (Maybe Property
old, Maybe Property
new) of
          (Just Property
_, Maybe Property
Nothing) -> ([Property] -> [Property]) -> GoT m ()
forall (go :: * -> *).
MonadGo go =>
([Property] -> [Property]) -> go ()
modifyProperties (([Property] -> [Property]) -> GoT m ())
-> ([Property] -> [Property]) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ d -> [Property] -> [Property]
forall a. Descriptor a => a -> [Property] -> [Property]
remove d
descriptor
          (Maybe Property
Nothing, Just Property
value') -> ([Property] -> [Property]) -> GoT m ()
forall (go :: * -> *).
MonadGo go =>
([Property] -> [Property]) -> go ()
modifyProperties (([Property] -> [Property]) -> GoT m ())
-> ([Property] -> [Property]) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ Property -> [Property] -> [Property]
forall a. a -> [a] -> [a]
add Property
value'
          (Just Property
value, Just Property
value') | Property
value Property -> Property -> Bool
forall a. Eq a => a -> a -> Bool
/= Property
value' -> do
            ([Property] -> [Property]) -> GoT m ()
forall (go :: * -> *).
MonadGo go =>
([Property] -> [Property]) -> go ()
modifyProperties (([Property] -> [Property]) -> GoT m ())
-> ([Property] -> [Property]) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ Property -> [Property] -> [Property]
forall a. a -> [a] -> [a]
add Property
value' ([Property] -> [Property])
-> ([Property] -> [Property]) -> [Property] -> [Property]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> [Property] -> [Property]
forall a. Descriptor a => a -> [Property] -> [Property]
remove d
descriptor
          (Maybe Property, Maybe Property)
_ -> () -> GoT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Either ModifyPropertyError ()
-> GoT m (Either ModifyPropertyError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModifyPropertyError ()
 -> GoT m (Either ModifyPropertyError ()))
-> Either ModifyPropertyError ()
-> GoT m (Either ModifyPropertyError ())
forall a b. (a -> b) -> a -> b
$ () -> Either ModifyPropertyError ()
forall a b. b -> Either a b
Right ()
    where remove :: a -> [Property] -> [Property]
remove a
descriptor = (Property -> Bool) -> [Property] -> [Property]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Property -> Bool) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Property -> Bool
forall a. Descriptor a => a -> Property -> Bool
propertyPredicate a
descriptor)
          add :: a -> [a] -> [a]
add a
value = (a
valuea -> [a] -> [a]
forall a. a -> [a] -> [a]
:)

  modifyGameInfo :: (GameInfo -> GameInfo)
-> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo))
modifyGameInfo GameInfo -> GameInfo
fn = do
    Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    let info :: GameInfo
info = BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
cursor
        info' :: GameInfo
info' = GameInfo -> GameInfo
fn GameInfo
info
    if GameInfo -> RootInfo
gameInfoRootInfo GameInfo
info RootInfo -> RootInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= GameInfo -> RootInfo
gameInfoRootInfo GameInfo
info'
      then Either ModifyGameInfoError (GameInfo, GameInfo)
-> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModifyGameInfoError (GameInfo, GameInfo)
 -> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo)))
-> Either ModifyGameInfoError (GameInfo, GameInfo)
-> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo))
forall a b. (a -> b) -> a -> b
$ ModifyGameInfoError
-> Either ModifyGameInfoError (GameInfo, GameInfo)
forall a b. a -> Either a b
Left (ModifyGameInfoError
 -> Either ModifyGameInfoError (GameInfo, GameInfo))
-> ModifyGameInfoError
-> Either ModifyGameInfoError (GameInfo, GameInfo)
forall a b. (a -> b) -> a -> b
$ GameInfo -> GameInfo -> ModifyGameInfoError
ModifyGameInfoCannotModifyRootInfo GameInfo
info GameInfo
info'
      else do
        GoT m ()
forall (go :: * -> *). MonadGo go => go ()
pushPosition
        Bool
_ <- Bool -> GoT m Bool
forall (go :: * -> *). MonadGo go => Bool -> go Bool
goToGameInfoNode Bool
True
        ([Property] -> [Property]) -> GoT m ()
forall (go :: * -> *).
MonadGo go =>
([Property] -> [Property]) -> go ()
modifyProperties (([Property] -> [Property]) -> GoT m ())
-> ([Property] -> [Property]) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \[Property]
props ->
          GameInfo -> [Property]
gameInfoToProperties GameInfo
info' [Property] -> [Property] -> [Property]
forall a. [a] -> [a] -> [a]
++ (Property -> Bool) -> [Property] -> [Property]
forall a. (a -> Bool) -> [a] -> [a]
filter ((PropertyType
GameInfoProperty PropertyType -> PropertyType -> Bool
forall a. Eq a => a -> a -> Bool
/=) (PropertyType -> Bool)
-> (Property -> PropertyType) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType) [Property]
props
        GoT m (Either PopPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either PopPositionError ())
popPosition GoT m (Either PopPositionError ())
-> (Either PopPositionError () -> GoT m ()) -> GoT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right () -> () -> GoT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Left PopPositionError
PopPositionStackEmpty ->
            String -> GoT m ()
forall a. HasCallStack => String -> a
error String
"GoT.modifyGameInfo: Internal error, PopPositionStackEmpty."
          Left PopPositionError
PopPositionCannotRetraceSteps ->
            String -> GoT m ()
forall a. HasCallStack => String -> a
error String
"GoT.modifyGameInfo: Internal error, PopPositionCannotRetraceSteps."
        Either ModifyGameInfoError (GameInfo, GameInfo)
-> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModifyGameInfoError (GameInfo, GameInfo)
 -> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo)))
-> Either ModifyGameInfoError (GameInfo, GameInfo)
-> GoT m (Either ModifyGameInfoError (GameInfo, GameInfo))
forall a b. (a -> b) -> a -> b
$ (GameInfo, GameInfo)
-> Either ModifyGameInfoError (GameInfo, GameInfo)
forall a b. b -> Either a b
Right (GameInfo
info, GameInfo
info')

  modifyVariationMode :: (VariationMode -> VariationMode) -> GoT m ()
modifyVariationMode VariationMode -> VariationMode
fn = do
    GoT m ()
forall (go :: * -> *). MonadGo go => go ()
pushPosition
    GoT m ()
forall (go :: * -> *). MonadGo go => go ()
goToRoot
    ValuedPropertyInfo VariationMode
-> (Maybe VariationMode -> Maybe VariationMode) -> GoT m ()
forall (go :: * -> *) v d.
(MonadGo go, ValuedDescriptor v d) =>
d -> (Maybe v -> Maybe v) -> go ()
modifyPropertyValue ValuedPropertyInfo VariationMode
propertyST ((Maybe VariationMode -> Maybe VariationMode) -> GoT m ())
-> (Maybe VariationMode -> Maybe VariationMode) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \Maybe VariationMode
maybeOld ->
      -- If the new variation mode is equal to the old effective variation mode
      -- (effective applying the default if the property isn't present), then
      -- leave the property unchanged.  Otherwise, apply the new variation mode,
      -- deleting the property if the default variation mode is selected.  We
      -- don't delete the property if @maybeOld == Just new == Just
      -- defaultVariationMode@, because we don't want to trigger dirtyness
      -- unnecessarily.
      let old :: VariationMode
old = VariationMode -> Maybe VariationMode -> VariationMode
forall a. a -> Maybe a -> a
fromMaybe VariationMode
defaultVariationMode Maybe VariationMode
maybeOld
          new :: VariationMode
new = VariationMode -> VariationMode
fn VariationMode
old
      in if VariationMode
new VariationMode -> VariationMode -> Bool
forall a. Eq a => a -> a -> Bool
== VariationMode
old
         then Maybe VariationMode
maybeOld
         else if VariationMode
new VariationMode -> VariationMode -> Bool
forall a. Eq a => a -> a -> Bool
== VariationMode
defaultVariationMode
              then Maybe VariationMode
forall a. Maybe a
Nothing
              else VariationMode -> Maybe VariationMode
forall a. a -> Maybe a
Just VariationMode
new
    Either PopPositionError ()
result <- GoT m (Either PopPositionError ())
forall (go :: * -> *).
MonadGo go =>
go (Either PopPositionError ())
popPosition
    case Either PopPositionError ()
result of
      Right () -> () -> GoT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Left PopPositionError
PopPositionStackEmpty ->
        String -> GoT m ()
forall a. HasCallStack => String -> a
error String
"GoT.modifyVariationMode: Internal error, got PopPositionStackEmpty."
      Left PopPositionError
PopPositionCannotRetraceSteps ->
        String -> GoT m ()
forall a. HasCallStack => String -> a
error String
"GoT.modifyVariationMode: Internal error, got PopPositionCannotRetraceSteps."

  addChildAt :: Int -> Node -> GoT m ()
addChildAt Int
index Node
node = do
    Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    let childCount :: Int
childCount = Cursor -> Int
cursorChildCount Cursor
cursor
        indexCapped :: Int
indexCapped = if Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
0
                      else if Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
childCount then Int
childCount
                      else Int
index
    let cursor' :: Cursor
cursor' = (Node -> Node) -> Cursor -> Cursor
cursorModifyNode (Int -> Node -> Node -> Node
Tree.addChildAt Int
indexCapped Node
node) Cursor
cursor
    (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall (m :: * -> *).
Monad m =>
(GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState ((GoState (GoT m) -> GoState (GoT m)) -> GoT m ())
-> (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \GoState (GoT m)
state ->
      GoState (GoT m)
state { stateCursor :: Cursor
stateCursor = Cursor
cursor'
            , statePathStack :: PathStack
statePathStack = (Step -> Step)
-> (Step -> Step)
-> (Step -> Step)
-> Cursor
-> PathStack
-> PathStack
forall a.
(Step -> a)
-> (Step -> a) -> (Step -> a) -> Cursor -> PathStack -> [[a]]
foldPathStack
                               (\Step
step -> case Step
step of
                                   GoUp Int
n -> Int -> Step
GoUp (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
indexCapped then Int
n else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                                   down :: Step
down@(GoDown Int
_) -> Step
down)
                               (\Step
step -> case Step
step of
                                   up :: Step
up@(GoUp Int
_) -> Step
up
                                   GoDown Int
n -> Int -> Step
GoDown (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
indexCapped then Int
n else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                               Step -> Step
forall a. a -> a
id
                               Cursor
cursor'
                               (GoState (GoT m) -> PathStack
forall (go :: * -> *). GoState go -> PathStack
statePathStack GoState (GoT m)
state)
            }
    Event (GoT m) (ChildAddedHandler (GoT m))
-> (ChildAddedHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (ChildAddedHandler (GoT m))
forall (go :: * -> *). Event go (ChildAddedHandler go)
childAddedEvent (ChildAddedHandler (GoT m) -> ChildAddedHandler (GoT m)
forall a b. (a -> b) -> a -> b
$ Int
indexCapped)

  deleteChildAt :: Int -> GoT m (Either NodeDeleteError ())
deleteChildAt Int
index = do
    Int
childCount <- Cursor -> Int
cursorChildCount (Cursor -> Int) -> GoT m Cursor -> GoT m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
    if Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
childCount
      then Either NodeDeleteError () -> GoT m (Either NodeDeleteError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either NodeDeleteError () -> GoT m (Either NodeDeleteError ()))
-> Either NodeDeleteError () -> GoT m (Either NodeDeleteError ())
forall a b. (a -> b) -> a -> b
$ NodeDeleteError -> Either NodeDeleteError ()
forall a b. a -> Either a b
Left NodeDeleteError
NodeDeleteBadIndex
      else do Int -> GoT m Bool
forall (go :: * -> *). MonadGo go => Int -> go Bool
goDown Int
index GoT m Bool -> (Bool -> GoT m ()) -> GoT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \Bool
ok -> Bool -> GoT m () -> GoT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$ String -> GoT m ()
forall a. HasCallStack => String -> a
error String
"GoT.deleteChildAt: Internal error, index isn't valid."
              Cursor
childCursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
              Bool
deletingNodeOnPath <- Cursor -> PathStack -> Bool
doesPathStackEnterCurrentNode (Cursor -> PathStack -> Bool)
-> GoT m Cursor -> GoT m (PathStack -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                    Cursor -> GoT m Cursor
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cursor
childCursor GoT m (PathStack -> Bool) -> GoT m PathStack -> GoT m Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GoT m PathStack
forall (m :: * -> *). Monad m => GoT m PathStack
getPathStack
              GoT m Bool
forall (go :: * -> *). MonadGo go => go Bool
goUp GoT m Bool -> (Bool -> GoT m ()) -> GoT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
ok -> Bool -> GoT m () -> GoT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$ String -> GoT m ()
forall a. HasCallStack => String -> a
error String
"GoT.deleteChildAt: Internal error, can't go up."
              if Bool
deletingNodeOnPath
                then Either NodeDeleteError () -> GoT m (Either NodeDeleteError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either NodeDeleteError () -> GoT m (Either NodeDeleteError ()))
-> Either NodeDeleteError () -> GoT m (Either NodeDeleteError ())
forall a b. (a -> b) -> a -> b
$ NodeDeleteError -> Either NodeDeleteError ()
forall a b. a -> Either a b
Left NodeDeleteError
NodeDeleteOnPathStack
                else do Cursor
cursor <- GoT m Cursor
forall (go :: * -> *). MonadGo go => go Cursor
getCursor
                        let cursor' :: Cursor
cursor' = (Node -> Node) -> Cursor -> Cursor
cursorModifyNode (Int -> Node -> Node
Tree.deleteChildAt Int
index) Cursor
cursor
                        (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall (m :: * -> *).
Monad m =>
(GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState ((GoState (GoT m) -> GoState (GoT m)) -> GoT m ())
-> (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ \GoState (GoT m)
state ->
                          GoState (GoT m)
state { stateCursor :: Cursor
stateCursor = Cursor
cursor'
                                , statePathStack :: PathStack
statePathStack =
                                  (Step -> Step)
-> (Step -> Step)
-> (Step -> Step)
-> Cursor
-> PathStack
-> PathStack
forall a.
(Step -> a)
-> (Step -> a) -> (Step -> a) -> Cursor -> PathStack -> [[a]]
foldPathStack
                                  (\Step
step -> case Step
step of
                                      GoUp Int
n -> Int -> Step
GoUp (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
index then Int
n else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                      down :: Step
down@(GoDown Int
_) -> Step
down)
                                  (\Step
step -> case Step
step of
                                      up :: Step
up@(GoUp Int
_) -> Step
up
                                      GoDown Int
n -> Int -> Step
GoDown (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
index then Int
n else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                                  Step -> Step
forall a. a -> a
id
                                  Cursor
cursor'
                                  (GoState (GoT m) -> PathStack
forall (go :: * -> *). GoState go -> PathStack
statePathStack GoState (GoT m)
state)
                                }
                        Event (GoT m) (ChildDeletedHandler (GoT m))
-> (ChildDeletedHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (ChildDeletedHandler (GoT m))
forall (go :: * -> *). Event go (ChildDeletedHandler go)
childDeletedEvent (ChildDeletedHandler (GoT m) -> ChildDeletedHandler (GoT m)
forall a b. (a -> b) -> a -> b
$ Cursor
childCursor)
                        Either NodeDeleteError () -> GoT m (Either NodeDeleteError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either NodeDeleteError () -> GoT m (Either NodeDeleteError ()))
-> Either NodeDeleteError () -> GoT m (Either NodeDeleteError ())
forall a b. (a -> b) -> a -> b
$ () -> Either NodeDeleteError ()
forall a b. b -> Either a b
Right ()

  on :: Event (GoT m) h -> h -> GoT m ()
on Event (GoT m) h
event h
handler = (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall (m :: * -> *).
Monad m =>
(GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState ((GoState (GoT m) -> GoState (GoT m)) -> GoT m ())
-> (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
forall a b. (a -> b) -> a -> b
$ Event (GoT m) h -> h -> GoState (GoT m) -> GoState (GoT m)
forall (go :: * -> *) h.
Event go h -> h -> GoState go -> GoState go
addHandler Event (GoT m) h
event h
handler

-- | Takes a step up the game tree, updates the path stack according to the
-- given function, then fires navigation and game info changed events as
-- appropriate, finally returning true.  When at the root of the tree, none of
-- this happens and false is returned.
goUp' :: Monad m => (PathStack -> PathStack) -> GoT m Bool
goUp' :: (PathStack -> PathStack) -> GoT m Bool
goUp' PathStack -> PathStack
pathStackFn = do
  state :: GoState (GoT m)
state@(GoState { stateCursor :: forall (go :: * -> *). GoState go -> Cursor
stateCursor = Cursor
cursor
                 , statePathStack :: forall (go :: * -> *). GoState go -> PathStack
statePathStack = PathStack
pathStack
                 }) <- GoT m (GoState (GoT m))
forall (m :: * -> *). Monad m => GoT m (GoState (GoT m))
getState
  case Cursor -> Maybe Cursor
cursorParent Cursor
cursor of
    Maybe Cursor
Nothing -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Cursor
parent -> do
      let index :: Int
index = Cursor -> Int
cursorChildIndex Cursor
cursor
      GoState (GoT m) -> GoT m ()
forall (m :: * -> *). Monad m => GoState (GoT m) -> GoT m ()
putState GoState (GoT m)
state { stateCursor :: Cursor
stateCursor = Cursor
parent
                     , statePathStack :: PathStack
statePathStack = PathStack -> PathStack
pathStackFn PathStack
pathStack
                     }
      Event (GoT m) (NavigationHandler (GoT m))
-> (NavigationHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (NavigationHandler (GoT m))
forall (go :: * -> *). Event go (NavigationHandler go)
navigationEvent (NavigationHandler (GoT m) -> NavigationHandler (GoT m)
forall a b. (a -> b) -> a -> b
$ Int -> Step
GoUp Int
index)

      -- The current game info changes when navigating up from a node that has
      -- game info properties.
      Bool -> GoT m () -> GoT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Property -> Bool) -> [Property] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((PropertyType
GameInfoProperty PropertyType -> PropertyType -> Bool
forall a. Eq a => a -> a -> Bool
==) (PropertyType -> Bool)
-> (Property -> PropertyType) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType) ([Property] -> Bool) -> [Property] -> Bool
forall a b. (a -> b) -> a -> b
$ Cursor -> [Property]
cursorProperties Cursor
cursor) (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$
        Event (GoT m) (GameInfoChangedHandler (GoT m))
-> (GameInfoChangedHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (GameInfoChangedHandler (GoT m))
forall (go :: * -> *). Event go (GameInfoChangedHandler go)
gameInfoChangedEvent (\GameInfoChangedHandler (GoT m)
f -> GameInfoChangedHandler (GoT m)
f (BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
cursor)
                                           (BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
parent))
      Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Takes a step down the game tree, updates the path stack according to the
-- given function, then fires navigation and game info changed events as
-- appropriate, finally returning true.  When the child index is invalid, none
-- of this happens and false is returned.
goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m Bool
goDown' :: Int -> (PathStack -> PathStack) -> GoT m Bool
goDown' Int
index PathStack -> PathStack
pathStackFn = do
  state :: GoState (GoT m)
state@(GoState { stateCursor :: forall (go :: * -> *). GoState go -> Cursor
stateCursor = Cursor
cursor
                 , statePathStack :: forall (go :: * -> *). GoState go -> PathStack
statePathStack = PathStack
pathStack
                 }) <- GoT m (GoState (GoT m))
forall (m :: * -> *). Monad m => GoT m (GoState (GoT m))
getState
  case Int -> [Cursor] -> [Cursor]
forall a. Int -> [a] -> [a]
drop Int
index ([Cursor] -> [Cursor]) -> [Cursor] -> [Cursor]
forall a b. (a -> b) -> a -> b
$ Cursor -> [Cursor]
cursorChildren Cursor
cursor of
    [] -> Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Cursor
child:[Cursor]
_ -> do
      GoState (GoT m) -> GoT m ()
forall (m :: * -> *). Monad m => GoState (GoT m) -> GoT m ()
putState GoState (GoT m)
state { stateCursor :: Cursor
stateCursor = Cursor
child
                     , statePathStack :: PathStack
statePathStack = PathStack -> PathStack
pathStackFn PathStack
pathStack
                     }
      Event (GoT m) (NavigationHandler (GoT m))
-> (NavigationHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (NavigationHandler (GoT m))
forall (go :: * -> *). Event go (NavigationHandler go)
navigationEvent (NavigationHandler (GoT m) -> NavigationHandler (GoT m)
forall a b. (a -> b) -> a -> b
$ Int -> Step
GoDown Int
index)

      -- The current game info changes when navigating down to a node that has
      -- game info properties.
      Bool -> GoT m () -> GoT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Property -> Bool) -> [Property] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((PropertyType
GameInfoProperty PropertyType -> PropertyType -> Bool
forall a. Eq a => a -> a -> Bool
==) (PropertyType -> Bool)
-> (Property -> PropertyType) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType) ([Property] -> Bool) -> [Property] -> Bool
forall a b. (a -> b) -> a -> b
$ Cursor -> [Property]
cursorProperties Cursor
child) (GoT m () -> GoT m ()) -> GoT m () -> GoT m ()
forall a b. (a -> b) -> a -> b
$
        Event (GoT m) (GameInfoChangedHandler (GoT m))
-> (GameInfoChangedHandler (GoT m) -> GoT m ()) -> GoT m ()
forall (m :: * -> *) h.
Monad m =>
Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) (GameInfoChangedHandler (GoT m))
forall (go :: * -> *). Event go (GameInfoChangedHandler go)
gameInfoChangedEvent (\GameInfoChangedHandler (GoT m)
f -> GameInfoChangedHandler (GoT m)
f (BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
cursor)
                                           (BoardState -> GameInfo
boardGameInfo (BoardState -> GameInfo) -> BoardState -> GameInfo
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
child))
      Bool -> GoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Returns the current path stack.
getPathStack :: Monad m => GoT m PathStack
getPathStack :: GoT m PathStack
getPathStack = (GoState (GoT m) -> PathStack)
-> GoT m (GoState (GoT m)) -> GoT m PathStack
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM GoState (GoT m) -> PathStack
forall (go :: * -> *). GoState go -> PathStack
statePathStack GoT m (GoState (GoT m))
forall (m :: * -> *). Monad m => GoT m (GoState (GoT m))
getState

doesPathStackEnterCurrentNode :: Cursor -> PathStack -> Bool
doesPathStackEnterCurrentNode :: Cursor -> PathStack -> Bool
doesPathStackEnterCurrentNode Cursor
cursor PathStack
pathStack =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [[Bool]] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Step -> Bool)
-> (Step -> Bool)
-> (Step -> Bool)
-> Cursor
-> PathStack
-> [[Bool]]
forall a.
(Step -> a)
-> (Step -> a) -> (Step -> a) -> Cursor -> PathStack -> [[a]]
foldPathStack (Bool -> Step -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> Step -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> Step -> Bool
forall a b. a -> b -> a
const Bool
False) Cursor
cursor PathStack
pathStack

-- | Maps over a path stack, updating with the given functions all steps that
-- enter and leave the cursor's current node.
foldPathStack :: (Step -> a)
              -> (Step -> a)
              -> (Step -> a)
              -> Cursor
              -> PathStack
              -> [[a]]
foldPathStack :: (Step -> a)
-> (Step -> a) -> (Step -> a) -> Cursor -> PathStack -> [[a]]
foldPathStack Step -> a
_ Step -> a
_ Step -> a
_ Cursor
_ [] = []
foldPathStack Step -> a
onEnter Step -> a
onExit Step -> a
onOther Cursor
cursor0 PathStack
paths =
  ((Cursor, [Step]), [[a]]) -> [[a]]
forall a b. (a, b) -> b
snd (((Cursor, [Step]), [[a]]) -> [[a]])
-> ((Cursor, [Step]), [[a]]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ ((Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a]))
-> (Cursor, [Step]) -> PathStack -> ((Cursor, [Step]), [[a]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a])
updatePath (Cursor
cursor0, []) PathStack
paths
  where -- updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a])
        updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a])
updatePath = ((Cursor, [Step]) -> Step -> ((Cursor, [Step]), a))
-> (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Cursor, [Step]) -> Step -> ((Cursor, [Step]), a)
updateStep
        -- updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), a)
        updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), a)
updateStep (Cursor
cursor, []) Step
step = ((Step -> Cursor -> Cursor
takeStep Step
step Cursor
cursor, [Step -> Step
reverseStep Step
step]), Step -> a
onExit Step
step)
        updateStep (Cursor
cursor, pathToInitial :: [Step]
pathToInitial@(Step
stepToInitial:[Step]
restToInitial)) Step
step =
          let pathToInitial' :: [Step]
pathToInitial' = if Step
stepToInitial Step -> Step -> Bool
forall a. Eq a => a -> a -> Bool
== Step
step
                               then [Step]
restToInitial
                               else Step -> Step
reverseStep Step
stepStep -> [Step] -> [Step]
forall a. a -> [a] -> [a]
:[Step]
pathToInitial
          in ((Step -> Cursor -> Cursor
takeStep Step
step Cursor
cursor, [Step]
pathToInitial'),
              if [Step] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Step]
pathToInitial' then Step -> a
onEnter Step
step else Step -> a
onOther Step
step)

-- | Fires all of the handlers for the given event, using the given function to
-- create a Go action from each of the handlers (normally themselves functions
-- that create Go actions, if they're not just Go actions directly, depending on
-- the event).
fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire :: Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire Event (GoT m) h
event h -> GoT m ()
handlerGenerator = do
  GoState (GoT m)
state <- GoT m (GoState (GoT m))
forall (m :: * -> *). Monad m => GoT m (GoState (GoT m))
getState
  (h -> GoT m ()) -> [h] -> GoT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ h -> GoT m ()
handlerGenerator ([h] -> GoT m ()) -> [h] -> GoT m ()
forall a b. (a -> b) -> a -> b
$ Event (GoT m) h -> GoState (GoT m) -> [h]
forall (go :: * -> *) h. Event go h -> GoState go -> [h]
eventStateGetter Event (GoT m) h
event GoState (GoT m)
state

-- | A type of event in a Go monad that can be handled by executing an action.
-- @go@ is the type of the Go monad.  @h@ is the handler type, a function that
-- takes some arguments relating to the event and returns an action in the Go
-- monad.  The arguments to the handler are usually things that would be
-- difficult to recover from the state of the monad alone, for example the
-- 'Step' associated with a 'navigationEvent'.
--
-- The 'Eq', 'Ord', and 'Show' instances use events' names, via 'eventName'.
data Event go h = Event
  { Event go h -> String
eventName :: String
  , Event go h -> GoState go -> [h]
eventStateGetter :: GoState go -> [h]
  , Event go h -> [h] -> GoState go -> GoState go
eventStateSetter :: [h] -> GoState go -> GoState go
  , Event go h -> go () -> h
eventHandlerFromAction :: go () -> h
  }

instance Eq (Event go h) where
  == :: Event go h -> Event go h -> Bool
(==) = String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> (Event go h -> String) -> Event go h -> Event go h -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`F.on` Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName

instance Ord (Event go h) where
  compare :: Event go h -> Event go h -> Ordering
compare = (Event go h -> String) -> Event go h -> Event go h -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName

instance Show (Event go h) where
  show :: Event go h -> String
show = Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName

-- | An existential type for any event in a particular Go monad.  Like 'Event',
-- the 'Eq', 'Ord', and 'Show' instances use events' names, via 'eventName'.
data AnyEvent go = forall h. AnyEvent (Event go h)

instance Eq (AnyEvent go) where
  (AnyEvent Event go h
e) == :: AnyEvent go -> AnyEvent go -> Bool
== (AnyEvent Event go h
e') = Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName Event go h
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName Event go h
e'

instance Ord (AnyEvent go) where
  compare :: AnyEvent go -> AnyEvent go -> Ordering
compare (AnyEvent Event go h
e) (AnyEvent Event go h
e') = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName Event go h
e) (Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName Event go h
e')

instance Show (AnyEvent go) where
  show :: AnyEvent go -> String
show (AnyEvent Event go h
e) = Event go h -> String
forall (go :: * -> *) h. Event go h -> String
eventName Event go h
e

addHandler :: Event go h -> h -> GoState go -> GoState go
addHandler :: Event go h -> h -> GoState go -> GoState go
addHandler Event go h
event h
handler GoState go
state =
  Event go h -> [h] -> GoState go -> GoState go
forall (go :: * -> *) h.
Event go h -> [h] -> GoState go -> GoState go
eventStateSetter Event go h
event (Event go h -> GoState go -> [h]
forall (go :: * -> *) h. Event go h -> GoState go -> [h]
eventStateGetter Event go h
event GoState go
state [h] -> [h] -> [h]
forall a. [a] -> [a] -> [a]
++ [h
handler]) GoState go
state

-- | An event corresponding to a child node being added to the current node.
childAddedEvent :: Event go (ChildAddedHandler go)
childAddedEvent :: Event go (ChildAddedHandler go)
childAddedEvent = Event :: forall (go :: * -> *) h.
String
-> (GoState go -> [h])
-> ([h] -> GoState go -> GoState go)
-> (go () -> h)
-> Event go h
Event
  { eventName :: String
eventName = String
"childAddedEvent"
  , eventStateGetter :: GoState go -> [ChildAddedHandler go]
eventStateGetter = GoState go -> [ChildAddedHandler go]
forall (go :: * -> *). GoState go -> [ChildAddedHandler go]
stateChildAddedHandlers
  , eventStateSetter :: [ChildAddedHandler go] -> GoState go -> GoState go
eventStateSetter = \[ChildAddedHandler go]
handlers GoState go
state -> GoState go
state { stateChildAddedHandlers :: [ChildAddedHandler go]
stateChildAddedHandlers = [ChildAddedHandler go]
handlers }
  , eventHandlerFromAction :: go () -> ChildAddedHandler go
eventHandlerFromAction = go () -> ChildAddedHandler go
forall a b. a -> b -> a
const
  }

-- | A handler for 'childAddedEvent's.  Called with the index of the child added
-- to the current node.
type ChildAddedHandler go = Int -> go ()

-- | An event corresponding to the deletion of one of the current node's
-- children.
childDeletedEvent :: Event go (ChildDeletedHandler go)
childDeletedEvent :: Event go (ChildDeletedHandler go)
childDeletedEvent = Event :: forall (go :: * -> *) h.
String
-> (GoState go -> [h])
-> ([h] -> GoState go -> GoState go)
-> (go () -> h)
-> Event go h
Event
  { eventName :: String
eventName = String
"childDeletedEvent"
  , eventStateGetter :: GoState go -> [ChildDeletedHandler go]
eventStateGetter = GoState go -> [ChildDeletedHandler go]
forall (go :: * -> *). GoState go -> [ChildDeletedHandler go]
stateChildDeletedHandlers
  , eventStateSetter :: [ChildDeletedHandler go] -> GoState go -> GoState go
eventStateSetter = \[ChildDeletedHandler go]
handlers GoState go
state -> GoState go
state { stateChildDeletedHandlers :: [ChildDeletedHandler go]
stateChildDeletedHandlers = [ChildDeletedHandler go]
handlers }
  , eventHandlerFromAction :: go () -> ChildDeletedHandler go
eventHandlerFromAction = go () -> ChildDeletedHandler go
forall a b. a -> b -> a
const
  }

-- | A handler for 'childDeletedEvent's.  It is called with a cursor at the
-- child that was deleted (this cursor is now out of date).
type ChildDeletedHandler go = Cursor -> go ()

-- | An event that is fired when the current game info changes, either by
-- navigating past a node with game info properties, or by modifying the current
-- game info properties.
gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)
gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)
gameInfoChangedEvent = Event :: forall (go :: * -> *) h.
String
-> (GoState go -> [h])
-> ([h] -> GoState go -> GoState go)
-> (go () -> h)
-> Event go h
Event
  { eventName :: String
eventName = String
"gameInfoChangedEvent"
  , eventStateGetter :: GoState go -> [GameInfoChangedHandler go]
eventStateGetter = GoState go -> [GameInfoChangedHandler go]
forall (go :: * -> *). GoState go -> [GameInfoChangedHandler go]
stateGameInfoChangedHandlers
  , eventStateSetter :: [GameInfoChangedHandler go] -> GoState go -> GoState go
eventStateSetter = \[GameInfoChangedHandler go]
handlers GoState go
state -> GoState go
state { stateGameInfoChangedHandlers :: [GameInfoChangedHandler go]
stateGameInfoChangedHandlers = [GameInfoChangedHandler go]
handlers }
  , eventHandlerFromAction :: go () -> GameInfoChangedHandler go
eventHandlerFromAction = (GameInfo -> go ()) -> GameInfoChangedHandler go
forall a b. a -> b -> a
const ((GameInfo -> go ()) -> GameInfoChangedHandler go)
-> (go () -> GameInfo -> go ())
-> go ()
-> GameInfoChangedHandler go
forall b c a. (b -> c) -> (a -> b) -> a -> c
. go () -> GameInfo -> go ()
forall a b. a -> b -> a
const
  }

-- | A handler for 'gameInfoChangedEvent's.  It is called with the old game info
-- then the new game info.
type GameInfoChangedHandler go = GameInfo -> GameInfo -> go ()

-- | An event that is fired when a single step up or down in a game tree is
-- made.
navigationEvent :: Event go (NavigationHandler go)
navigationEvent :: Event go (NavigationHandler go)
navigationEvent = Event :: forall (go :: * -> *) h.
String
-> (GoState go -> [h])
-> ([h] -> GoState go -> GoState go)
-> (go () -> h)
-> Event go h
Event
  { eventName :: String
eventName = String
"navigationEvent"
  , eventStateGetter :: GoState go -> [NavigationHandler go]
eventStateGetter = GoState go -> [NavigationHandler go]
forall (go :: * -> *). GoState go -> [NavigationHandler go]
stateNavigationHandlers
  , eventStateSetter :: [NavigationHandler go] -> GoState go -> GoState go
eventStateSetter = \[NavigationHandler go]
handlers GoState go
state -> GoState go
state { stateNavigationHandlers :: [NavigationHandler go]
stateNavigationHandlers = [NavigationHandler go]
handlers }
  , eventHandlerFromAction :: go () -> NavigationHandler go
eventHandlerFromAction = go () -> NavigationHandler go
forall a b. a -> b -> a
const
  }

-- | A handler for 'navigationEvent's.
--
-- A navigation handler may navigate further, but beware infinite recursion.  A
-- navigation handler must end on the same node on which it started.
type NavigationHandler go = Step -> go ()

-- | An event corresponding to a modification to the properties list of the
-- current node.
propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)
propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)
propertiesModifiedEvent = Event :: forall (go :: * -> *) h.
String
-> (GoState go -> [h])
-> ([h] -> GoState go -> GoState go)
-> (go () -> h)
-> Event go h
Event
  { eventName :: String
eventName = String
"propertiesModifiedEvent"
  , eventStateGetter :: GoState go -> [PropertiesModifiedHandler go]
eventStateGetter = GoState go -> [PropertiesModifiedHandler go]
forall (go :: * -> *). GoState go -> [PropertiesModifiedHandler go]
statePropertiesModifiedHandlers
  , eventStateSetter :: [PropertiesModifiedHandler go] -> GoState go -> GoState go
eventStateSetter = \[PropertiesModifiedHandler go]
handlers GoState go
state -> GoState go
state { statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go]
statePropertiesModifiedHandlers = [PropertiesModifiedHandler go]
handlers }
  , eventHandlerFromAction :: go () -> PropertiesModifiedHandler go
eventHandlerFromAction = ([Property] -> go ()) -> PropertiesModifiedHandler go
forall a b. a -> b -> a
const (([Property] -> go ()) -> PropertiesModifiedHandler go)
-> (go () -> [Property] -> go ())
-> go ()
-> PropertiesModifiedHandler go
forall b c a. (b -> c) -> (a -> b) -> a -> c
. go () -> [Property] -> go ()
forall a b. a -> b -> a
const
  }

-- | A handler for 'propertiesModifiedEvent's.  It is called with the old
-- property list then the new property list.
type PropertiesModifiedHandler go = [Property] -> [Property] -> go ()

-- | An event corresponding to a change in the active 'VariationMode'.  This can
-- happen when modifying the 'ST' property, and also when navigating between
-- collections (as they have different root nodes).
variationModeChangedEvent :: Event go (VariationModeChangedHandler go)
variationModeChangedEvent :: Event go (VariationModeChangedHandler go)
variationModeChangedEvent = Event :: forall (go :: * -> *) h.
String
-> (GoState go -> [h])
-> ([h] -> GoState go -> GoState go)
-> (go () -> h)
-> Event go h
Event
  { eventName :: String
eventName = String
"variationModeChangedEvent"
  , eventStateGetter :: GoState go -> [VariationModeChangedHandler go]
eventStateGetter = GoState go -> [VariationModeChangedHandler go]
forall (go :: * -> *).
GoState go -> [VariationModeChangedHandler go]
stateVariationModeChangedHandlers
  , eventStateSetter :: [VariationModeChangedHandler go] -> GoState go -> GoState go
eventStateSetter = \[VariationModeChangedHandler go]
handlers GoState go
state -> GoState go
state { stateVariationModeChangedHandlers :: [VariationModeChangedHandler go]
stateVariationModeChangedHandlers = [VariationModeChangedHandler go]
handlers }
  , eventHandlerFromAction :: go () -> VariationModeChangedHandler go
eventHandlerFromAction = (VariationMode -> go ()) -> VariationModeChangedHandler go
forall a b. a -> b -> a
const ((VariationMode -> go ()) -> VariationModeChangedHandler go)
-> (go () -> VariationMode -> go ())
-> go ()
-> VariationModeChangedHandler go
forall b c a. (b -> c) -> (a -> b) -> a -> c
. go () -> VariationMode -> go ()
forall a b. a -> b -> a
const
  }
-- TODO Test that this is fired when moving between root nodes in a collection.
-- For now, since we don't support multiple trees in a collection, we don't need
-- to worry about checking for active variation mode change on navigation.

-- | A handler for 'variationModeChangedEvent's.  It is called with the old
-- variation mode then the new variation mode.
type VariationModeChangedHandler go = VariationMode -> VariationMode -> go ()