goatee 0.3.1.3 → 0.4.0

raw patch · 33 files changed

+503/−286 lines, 33 filesdep ~basedep ~containersdep ~template-haskellsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, template-haskell

API changes (from Hackage documentation)

Files

• Setup.hs +1/−1
• goatee.cabal +17/−9
• src/Game/Goatee/App.hs +2/−2
• src/Game/Goatee/Common.hs +18/−1
• src/Game/Goatee/Common/Bigfloat.hs +1/−1
• src/Game/Goatee/Lib/Board.hs +2/−2
• src/Game/Goatee/Lib/Monad.hs +299/−81
• src/Game/Goatee/Lib/Parser.hs +1/−4
• src/Game/Goatee/Lib/Property.hs +1/−1
• src/Game/Goatee/Lib/Property/Base.hs +1/−4
• src/Game/Goatee/Lib/Property/Info.hs +1/−1
• src/Game/Goatee/Lib/Property/Parser.hs +2/−9
• src/Game/Goatee/Lib/Property/Renderer.hs +1/−1
• src/Game/Goatee/Lib/Property/Value.hs +1/−1
• src/Game/Goatee/Lib/Renderer.hs +1/−1
• src/Game/Goatee/Lib/Renderer/Tree.hs +1/−1
• src/Game/Goatee/Lib/Tree.hs +1/−4
• src/Game/Goatee/Lib/Types.hs +1/−4
• tests/Game/Goatee/Common/BigfloatTest.hs +1/−1
• tests/Game/Goatee/CommonTest.hs +1/−1
• tests/Game/Goatee/Lib/BoardTest.hs +1/−1
• tests/Game/Goatee/Lib/MonadTest.hs +137/−138
• tests/Game/Goatee/Lib/ParserTest.hs +1/−1
• tests/Game/Goatee/Lib/ParserTestUtils.hs +1/−4
• tests/Game/Goatee/Lib/Property/ParserTest.hs +1/−4
• tests/Game/Goatee/Lib/PropertyTest.hs +1/−1
• tests/Game/Goatee/Lib/RoundTripTest.hs +1/−1
• tests/Game/Goatee/Lib/TestInstances.hs +1/−1
• tests/Game/Goatee/Lib/TestUtils.hs +1/−1
• tests/Game/Goatee/Lib/TreeTest.hs +1/−1
• tests/Game/Goatee/Lib/TypesTest.hs +1/−1
• tests/Game/Goatee/Test/Common.hs +1/−1
• tests/Test.hs +1/−1

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,16 +1,16 @@ name: goatee-version: 0.3.1.3+version: 0.4.0 synopsis: A monadic take on a 2,500-year-old board game - library. category: Game license: AGPL-3 license-file: LICENSE-copyright: Copyright 2014-2018 Bryan Gardiner+copyright: Copyright 2014-2021 Bryan Gardiner author: Bryan Gardiner <bog@khumba.net> maintainer: Bryan Gardiner <bog@khumba.net> homepage: http://khumba.net/projects/goatee bug-reports: https://savannah.nongnu.org/projects/goatee/ tested-with: GHC-cabal-version: >=1.8+cabal-version: 2.0 build-type: Simple data-files: LICENSE description:@@ -28,11 +28,11 @@  library     build-depends:-        base >= 4 && < 5,-        containers >= 0.4 && < 0.6,+        base >= 4.12 && < 5,+        containers >= 0.4 && < 0.7,         mtl >= 2.1 && < 2.3,         parsec >= 3.1 && < 3.2,-        template-haskell >= 2.7 && < 2.14+        template-haskell >= 2.7 && < 2.17     exposed-modules:         Game.Goatee.App         Game.Goatee.Common@@ -46,11 +46,12 @@         Game.Goatee.Lib.Renderer.Tree         Game.Goatee.Lib.Tree         Game.Goatee.Lib.Types-    extensions:+    default-extensions:         ExistentialQuantification         FlexibleContexts         FlexibleInstances         FunctionalDependencies+        LambdaCase         MultiParamTypeClasses         UndecidableInstances     ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind@@ -61,11 +62,14 @@         Game.Goatee.Lib.Property.Renderer         Game.Goatee.Lib.Property.Value         Paths_goatee+    autogen-modules:+        Paths_goatee+    default-language: Haskell2010  test-suite test-goatee     build-depends:-        base >= 4 && < 5,-        containers >= 0.4 && < 0.6,+        base >= 4.12 && < 5,+        containers >= 0.4 && < 0.7,         goatee,         HUnit >= 1.2 && < 1.7,         mtl >= 2.1 && < 2.3,@@ -88,4 +92,8 @@         Game.Goatee.Lib.TreeTest         Game.Goatee.Lib.TypesTest         Game.Goatee.Test.Common+        Paths_goatee+    autogen-modules:+        Paths_goatee     type: exitcode-stdio-1.0+    default-language: Haskell2010

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -29,7 +29,7 @@  -- | A user-presentable copyright message. applicationCopyright :: String-applicationCopyright = "Copyright 2014-2018 Bryan Gardiner"+applicationCopyright = "Copyright 2014-2021 Bryan Gardiner"  -- | The home page for Goatee on the web. applicationWebsite :: String

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -32,6 +32,7 @@   forIndexM_,   whileM,   whileM',+  whileM'',   doWhileM,   ) where @@ -130,6 +131,22 @@                        case x of                          Nothing -> return ()                          Just y -> body y >> whileM' test body++-- | A while loop that supports returning a value, and also exiting early from+-- the body.+--+-- @whileM'' test body@ repeatedly evaluates @test@.  If the test produces a+-- @Right a@, then @body a@ is evaluated, and the loop will either repeat (if+-- @body@ returns @Nothing@) or exit (if @body@ returns a @Just r@).  If @test@+-- produces a @Left r@ at any point, then the loop immediately exits with that+-- @r@ value.+whileM'' :: Monad m => m (Either r a) -> (a -> m (Maybe r)) -> m r+whileM'' test body =+  test >>= \case+    Left r -> return r+    Right a -> body a >>= \case+      Just r -> return r+      Nothing -> whileM'' test body  -- | @doWhileM init body@ repeatedly calls @body@ with @init@.  As long as -- @body@ returns a @Right@ value, it is re-executed with the returned value.

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -82,7 +82,7 @@    , gameInfoAnnotatorName :: Maybe SimpleText   , gameInfoEntererName :: Maybe SimpleText-  } deriving (Show)+  } deriving (Eq, Show)  -- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data. emptyGameInfo :: RootInfo -> GameInfo

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -26,7 +26,24 @@   evalGoT, evalGo,   execGoT, execGo,   Step (..),-  NodeDeleteResult (..),+  -- * 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@@ -38,13 +55,14 @@   variationModeChangedEvent, VariationModeChangedHandler,   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), Applicative ((<*>), pure))-#endif #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)@@ -62,6 +80,9 @@ 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').@@ -188,12 +209,14 @@   pushPosition :: go ()    -- | Returns to the last position pushed onto the internal position stack via-  -- 'pushPosition'.  This action must be balanced by a 'pushPosition'.-  popPosition :: go ()+  -- '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.  This action must be balanced by a 'pushPosition'.-  dropPosition :: go ()+  -- 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]@@ -216,7 +239,14 @@   -- the same name, if one exists.  Fires 'propertiesModifiedEvent' if the   -- property has changed.   putProperty :: Property -> go ()-  putProperty property = modifyProperty property $ const $ Just property+  putProperty property = do+    result <- modifyProperty property $ const $ Just property+    case result of+      Right () -> return ()+      Left (ModifyPropertyCannotChangeType old new) ->+        error $ "MonadGo.putProperty: " +++        "Internal error, should not have attempted to change property type " +++        "(old '" ++ old ++ "', new '" ++ new ++ "')."    -- | Deletes a property from the current node, if it's set, and fires   -- 'propertiesModifiedEvent'.@@ -230,14 +260,30 @@   -- >    deleteProperty $ PL White   -- >    getPropertyValue propertyPL   deleteProperty :: Descriptor d => d -> go ()-  deleteProperty descriptor = modifyProperty descriptor $ const Nothing+  deleteProperty descriptor = do+    result <- modifyProperty descriptor $ const Nothing+    case result of+      Right () -> return ()+      Left (ModifyPropertyCannotChangeType old new) ->+        error $ "MonadGo.deleteProperty: " +++        "Internal error, should not have attempted to change property type " +++        "(old '" ++ old ++ "', new '" ++ new ++ "')."    -- | 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.-  modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go ()+  --+  -- 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@@ -246,8 +292,13 @@   -- 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 descriptor fn = modifyProperty descriptor $ \old ->-    propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old)+  modifyPropertyValue descriptor fn = modifyProperty descriptor modify >>= \case+    Right () -> return ()+    Left (ModifyPropertyCannotChangeType old new) ->+      error $ "MonadGo.modifyPropertyValue: Internal error, attempted to change " +++      "property type (old '" ++ old ++ "', new '" ++ new ++ "')."+    where modify old =+            propertyBuilder descriptor <$> fn (propertyValue descriptor <$> 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@@ -299,8 +350,13 @@   -- | 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.-  modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo+  -- 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.@@ -375,7 +431,7 @@                                 buildCoordList coords]                              }           ok <- goDown =<< subtract 1 . length . cursorChildren <$> getCursor-          unless ok $ fail "GoT.modifyAssignedStones: Failed to move to new child."+          unless ok $ error "GoT.modifyAssignedStones: Failed to move to new child."       else do         -- Get a map from getAllAssignedStones: Map Coord (Maybe Color)         allAssignedStones <- getAllAssignedStones@@ -438,14 +494,14 @@    -- | 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]@.  Fires a 'childAddedEvent' after the-  -- child is added.+  -- 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 NodeDeleteResult+  deleteChildAt :: Int -> go (Either NodeDeleteError ())    -- | Registers a new event handler for a given event type.   on :: Event go h -> h -> go ()@@ -456,16 +512,127 @@   on0 :: Event go h -> go () -> go ()   on0 event handler = on event $ eventHandlerFromAction event handler --- | The result of deleting a node.-data NodeDeleteResult =-  NodeDeleteOk-  -- ^ The node was deleted successfully.-  | NodeDeleteBadIndex-    -- ^ The node couldn't be deleted, because an invalid index was given.+-- | 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 (Eq, Show)++-- | Errors from attempting to navigate.  Thrown by 'goUpOrThrow',+-- 'goDownOrThrow', 'goLeftOrThrow', 'goRightOrThrow'.+data NavigationError =+  NavigationCouldNotMove+  -- ^ Could not make the requested motion.+  deriving (Eq, 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 (Eq, Show)++-- | Errors from 'dropPosition'.+data DropPositionError =+  DropPositionStackEmpty+  -- ^ There is no previous position to drop.  No action was taken.+  deriving (Eq, 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 (Eq, 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 (Eq, 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 (Bounded, Enum, Eq, Show)+  deriving (Eq, Show) +-- | Like 'goUp', but throws 'NavigationCouldNotMove' if at the root of the+-- tree.+goUpOrThrow :: (MonadGo m, MonadError GoError m) => m ()+goUpOrThrow = goUp >>= \case+  True -> return ()+  False -> throwError $ GoNavigationError NavigationCouldNotMove++-- | Like 'goDown', but throws 'NavigationCouldNotMove' if the requested child+-- does not exist.+goDownOrThrow :: (MonadGo m, MonadError GoError m) => Int -> m ()+goDownOrThrow index = goDown index >>= \case+  True -> return ()+  False -> throwError $ GoNavigationError NavigationCouldNotMove++-- | Like 'goLeft', but throws 'NavigationCouldNotMove' if there is no left+-- sibling to move to.+goLeftOrThrow :: (MonadGo m, MonadError GoError m) => m ()+goLeftOrThrow = goLeft >>= \case+  True -> return ()+  False -> throwError $ GoNavigationError NavigationCouldNotMove++-- | Like 'goRight', but throws 'NavigationCouldNotMove' if there is no right+-- sibling to move to.+goRightOrThrow :: (MonadGo m, MonadError GoError m) => m ()+goRightOrThrow = goRight >>= \case+  True -> return ()+  False -> throwError $ GoNavigationError NavigationCouldNotMove++-- | Same as 'popPosition', but throws errors rather than returning them.+popPositionOrThrow :: (MonadGo m, MonadError GoError m) => m ()+popPositionOrThrow =+  popPosition >>=+  either (throwError . GoPopPositionError) return++-- | Same as 'dropPosition', but throws errors rather than returning them.+dropPositionOrThrow :: (MonadGo m, MonadError GoError m) => m ()+dropPositionOrThrow =+  dropPosition >>=+  either (throwError . GoDropPositionError) 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 descriptor fn =+  modifyProperty descriptor fn >>=+  either (throwError . GoModifyPropertyError) return++-- | Same as 'modifyGameInfo', but throws errors rather than returning them.+modifyGameInfoOrThrow :: (MonadGo m, MonadError GoError m)+                      => (GameInfo -> GameInfo)+                      -> m (GameInfo, GameInfo)+modifyGameInfoOrThrow fn =+  modifyGameInfo fn >>=+  either (throwError . GoModifyGameInfoError) return++-- | Same as 'deleteChildAt', but throws errors rather than returning them.+deleteChildAtOrThrow :: (MonadGo m, MonadError GoError m) => Int -> m ()+deleteChildAtOrThrow index =+  deleteChildAt index >>=+  either (throwError . GoNodeDeleteError) return+ -- | The standard monad transformer for 'MonadGo'. newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a } @@ -482,8 +649,10 @@ instance Monad m => Monad (GoT m) where   return x = GoT $ return x   m >>= f = GoT $ goState . f =<< goState m-  fail = lift . fail +instance MonadFail m => MonadFail (GoT m) where+  fail = GoT . fail+ instance MonadTrans GoT where   lift = GoT . lift @@ -500,6 +669,14 @@   listen = GoT . listen . goState   pass = GoT . pass . goState +instance MonadError e m => MonadError e (GoT m) where+  throwError = lift . throwError+  catchError action handler =+    -- action :: GoT m a+    -- handler :: e -> GoT m a+    -- Need to call catchError :: StateT (GoState (GoT m)) m a -> (e -> StateT ...) -> StateT ...+    GoT $ catchError (goState action) (goState . 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)@@ -559,18 +736,22 @@     case (cursorParent cursor, cursorChildIndex cursor) of       (Nothing, _) -> return False       (Just _, 0) -> return False-      (Just _, n) -> do True <- goUp-                        True <- goDown $ n - 1-                        return True+      (Just _, n) -> goUp >>= \case+        True -> goDown (n - 1) >>= \case+          True -> return True+          False -> error "GoT.goLeft: Internal error, could not go down."+        False -> error "GoT.goLeft: Internal error, could not go up."    goRight = do     cursor <- getCursor     case (cursorParent cursor, cursorChildIndex cursor) of       (Nothing, _) -> return False       (Just parent, n) | n == cursorChildCount parent - 1 -> return False-      (Just _, n) -> do True <- goUp-                        True <- goDown $ n + 1-                        return True+      (Just _, n) -> goUp >>= \case+        True -> goDown (n + 1) >>= \case+          True -> return True+          False -> error "GoT.goRight: Internal error, could not go down."+        False -> error "GoT.goRight: Internal error, could not go up."    goToRoot = whileM goUp $ return () @@ -578,31 +759,52 @@     where findGameInfoNode = do             cursor <- getCursor             if hasGameInfo cursor-              then dropPosition >> return True+              then dropPosition >>= \case+                     Right () -> return True+                     Left DropPositionStackEmpty -> errorDropStackEmpty               else if isNothing $ cursorParent cursor-                   then do if goToRootIfNotFound then dropPosition else popPosition-                           return False+                   then if goToRootIfNotFound+                        then dropPosition >>= \case+                               Right () -> return False+                               Left DropPositionStackEmpty -> errorDropStackEmpty+                        else popPosition >>= \case+                               Right () -> return False+                               Left PopPositionStackEmpty -> errorPopStackEmpty+                               Left PopPositionCannotRetraceSteps -> errorPopCannotRetrace                    else goUp >> findGameInfoNode           hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor+          errorDropStackEmpty =+            error "GoT.goToGameInfoNode: Internal error, DropPositionStackEmpty."+          errorPopStackEmpty =+            error "GoT.goToGameInfoNode: Internal error, PopPositionStackEmpty."+          errorPopCannotRetrace =+            error "GoT.goToGameInfoNode: Internal error, PopPositionCannotRetraceSteps."    pushPosition = modifyState $ \state ->     state { statePathStack = []:statePathStack state }    popPosition = do-    getPathStack >>= \stack -> when (null stack) $-      fail "popPosition: No position to pop from the stack."+    getPathStack >>= \case+      [] -> return $ Left PopPositionStackEmpty+      _ -> do+        -- Drop each step in the top list of the path stack one at a time, until the+        -- top list is empty.+        maybeRetraceErrorResult <- whileM''+          (do ~(path:_) <- getPathStack  -- TODO Don't use irrefutable pattern.+              return $ if null path then Left Nothing else Right $ head path)+          (\step -> do+            ok <- takeStepM step $ \((_:steps):paths) -> steps:paths+            return $ if ok then Nothing else Just $ Just PopPositionCannotRetraceSteps) -    -- Drop each step in the top list of the path stack one at a time, until the-    -- top list is empty.-    whileM' (do path:_ <- getPathStack-                return $ if null path then Nothing else Just $ head path) $ \step -> do-      ok <- takeStepM step $ \((_:steps):paths) -> steps:paths-      unless ok $ fail "popPosition: Failed to retrace steps."+        case maybeRetraceErrorResult of+          Just err -> return $ Left err+          Nothing -> do+            -- Finally, drop the empty top of the path stack.+            modifyState $ \state -> case statePathStack state of+              []:rest -> state { statePathStack = rest }+              _ -> error "popPosition: Internal failure, top of path stack is not empty." -    -- Finally, drop the empty top of the path stack.-    modifyState $ \state -> case statePathStack state of-      []:rest -> state { statePathStack = rest }-      _ -> error "popPosition: Internal failure, top of path stack is not empty."+            return $ Right ()    dropPosition = do     state <- getState@@ -611,9 +813,11 @@     -- may still be needed to return to the second-on-stack position by a     -- following popPosition.     case statePathStack state of-      x:y:xs -> putState $ state { statePathStack = (x ++ y):xs }-      [_] -> putState $ state { statePathStack = [] }-      [] -> fail "dropPosition: No position to drop from the stack."+      x:y:xs -> do putState $ state { statePathStack = (x ++ y):xs }+                   return $ Right ()+      [_] -> do putState $ state { statePathStack = [] }+                return $ Right ()+      [] -> return $ Left DropPositionStackEmpty    modifyProperties fn = do     oldCursor <- getCursor@@ -646,15 +850,16 @@     let node = cursorNode cursor         old = findProperty descriptor node         new = fn old-    when (maybe False (not . propertyPredicate descriptor) new) $-      fail $ "modifyProperty: May not change property type: " ++-      show old ++ " -> " ++ show new ++ "."-    case (old, new) of-      (Just _, Nothing) -> modifyProperties $ remove descriptor-      (Nothing, Just value') -> modifyProperties $ add value'-      (Just value, Just value') | value /= value' ->-        modifyProperties $ add value' . remove descriptor-      _ -> return ()+    if (maybe False (not . propertyPredicate descriptor) new)+      then return $ Left $ ModifyPropertyCannotChangeType (show old) (show new)+      else do+        case (old, new) of+          (Just _, Nothing) -> modifyProperties $ remove descriptor+          (Nothing, Just value') -> modifyProperties $ add value'+          (Just value, Just value') | value /= value' -> do+            modifyProperties $ add value' . remove descriptor+          _ -> return ()+        return $ Right ()     where remove descriptor = filter (not . propertyPredicate descriptor)           add value = (value:) @@ -662,14 +867,20 @@     cursor <- getCursor     let info = boardGameInfo $ cursorBoard cursor         info' = fn info-    when (gameInfoRootInfo info /= gameInfoRootInfo info') $-      fail "Illegal modification of root info in modifyGameInfo."-    pushPosition-    _ <- goToGameInfoNode True-    modifyProperties $ \props ->-      gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props-    popPosition-    return info'+    if gameInfoRootInfo info /= gameInfoRootInfo info'+      then return $ Left $ ModifyGameInfoCannotModifyRootInfo info info'+      else do+        pushPosition+        _ <- goToGameInfoNode True+        modifyProperties $ \props ->+          gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props+        popPosition >>= \case+          Right () -> return ()+          Left PopPositionStackEmpty ->+            error "GoT.modifyGameInfo: Internal error, PopPositionStackEmpty."+          Left PopPositionCannotRetraceSteps ->+            error "GoT.modifyGameInfo: Internal error, PopPositionCannotRetraceSteps."+        return $ Right (info, info')    modifyVariationMode fn = do     pushPosition@@ -689,41 +900,48 @@          else if new == defaultVariationMode               then Nothing               else Just new-    popPosition+    result <- popPosition+    case result of+      Right () -> return ()+      Left PopPositionStackEmpty ->+        error "GoT.modifyVariationMode: Internal error, got PopPositionStackEmpty."+      Left PopPositionCannotRetraceSteps ->+        error "GoT.modifyVariationMode: Internal error, got PopPositionCannotRetraceSteps."    addChildAt index node = do     cursor <- getCursor     let childCount = cursorChildCount cursor-    when (index < 0 || index > childCount) $ fail $-      "Monad.addChildAt: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]."-    let cursor' = cursorModifyNode (Tree.addChildAt index node) cursor+        indexCapped = if index < 0 then 0+                      else if index > childCount then childCount+                      else index+    let cursor' = cursorModifyNode (Tree.addChildAt indexCapped node) cursor     modifyState $ \state ->       state { stateCursor = cursor'             , statePathStack = foldPathStack                                (\step -> case step of-                                   GoUp n -> GoUp $ if n < index then n else n + 1+                                   GoUp n -> GoUp $ if n < indexCapped then n else n + 1                                    down@(GoDown _) -> down)                                (\step -> case step of                                    up@(GoUp _) -> up-                                   GoDown n -> GoDown $ if n < index then n else n + 1)+                                   GoDown n -> GoDown $ if n < indexCapped then n else n + 1)                                id                                cursor'                                (statePathStack state)             }-    fire childAddedEvent ($ index)+    fire childAddedEvent ($ indexCapped)    deleteChildAt index = do     childCount <- cursorChildCount <$> getCursor     if index < 0 || index >= childCount-      then return NodeDeleteBadIndex+      then return $ Left NodeDeleteBadIndex       else do goDown index >>=-                \ok -> unless ok $ fail "GoT.deleteChildAt: Internal error, index isn't valid."+                \ok -> unless ok $ error "GoT.deleteChildAt: Internal error, index isn't valid."               childCursor <- getCursor               deletingNodeOnPath <- doesPathStackEnterCurrentNode <$>                                     pure childCursor <*> getPathStack-              goUp >>= \ok -> unless ok $ fail "GoT.deleteChildAt: Internal error, can't go up."+              goUp >>= \ok -> unless ok $ error "GoT.deleteChildAt: Internal error, can't go up."               if deletingNodeOnPath-                then return NodeDeleteOnPathStack+                then return $ Left NodeDeleteOnPathStack                 else do cursor <- getCursor                         let cursor' = cursorModifyNode (Tree.deleteChildAt index) cursor                         modifyState $ \state ->@@ -741,7 +959,7 @@                                   (statePathStack state)                                 }                         fire childDeletedEvent ($ childCursor)-                        return NodeDeleteOk+                        return $ Right ()    on event handler = modifyState $ addHandler event handler 

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -26,9 +26,6 @@   ) where  import Control.Arrow ((+++))-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<*), (*>))-#endif import Data.Maybe (fromMaybe) import Game.Goatee.Common import Game.Goatee.Lib.Board

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -35,9 +35,6 @@   defProperty, defValuedProperty,   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$))-#endif import Game.Goatee.Lib.Property.Value (PropertyValueType(..), nonePvt) import Game.Goatee.Lib.Renderer import Game.Goatee.Lib.Types

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -45,16 +45,9 @@   text,   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>))-#endif import Control.Monad (when) import Data.Char (isUpper, ord) import Data.Maybe (catMaybes)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid, mappend, mconcat, mempty)-#endif-import Data.Semigroup as Sem ((<>), Semigroup) import qualified Game.Goatee.Common.Bigfloat as BF import Game.Goatee.Lib.Types import Text.ParserCombinators.Parsec (@@ -74,7 +67,7 @@ -- between two @CoordList@s. newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList } -instance Sem.Semigroup CoordListMonoid where+instance Semigroup CoordListMonoid where   (<>) (CoordListMonoid x) (CoordListMonoid y) =     CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y)                               (coordListRects x ++ coordListRects y)

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -27,9 +27,6 @@   validateNode,   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif import Control.Monad (forM_, unless, when) import Control.Monad.Writer (Writer, execWriter, tell) import Data.Function (on)

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -47,9 +47,6 @@   Ruleset (..), RulesetType (..), fromRuleset, toRuleset,   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif import Data.Char (isSpace) import Data.Function (on) import Data.List (delete, groupBy, partition, sort)

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -19,18 +19,12 @@  module Game.Goatee.Lib.MonadTest (tests) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif import Control.Arrow ((&&&), second) import Control.Monad (forM_, liftM, replicateM_, void)-import Control.Monad.Writer (Writer, execWriter, runWriter, tell)+import Control.Monad.Writer (Writer, execWriter, execWriterT, runWriter, tell) import Data.List (sortBy, unfoldr) import qualified Data.Map as Map import Data.Maybe (fromJust, maybeToList)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid)-#endif import Data.Ord (comparing) import Game.Goatee.Common import Game.Goatee.Lib.Board@@ -45,13 +39,6 @@  {-# ANN module "HLint: ignore Reduce duplication" #-} -type LoggedGoM = GoT (Writer [String])--runLoggedGo :: LoggedGoM a -> Cursor -> (a, Cursor, [String])-runLoggedGo go cursor =-  let ((value, cursor'), log) = runWriter $ runGoT go cursor-  in (value, cursor', log)- tests = "Game.Goatee.Lib.Monad" ~: TestList   [ monadTests   , navigationTests@@ -170,7 +157,7 @@                 "False",                 "[B (Just (4,4))]"] -  , "invokes handlers when navigating" ~:+  , "invokes handlers when navigating" ~: do     let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing]         action = do on navigationEvent $ \step -> case step of                       GoUp index -> tell ["Up " ++ show index]@@ -178,11 +165,10 @@                     on navigationEvent $ \step -> case step of                       GoDown index -> tell ["Down " ++ show index]                       _ -> return ()-                    True <- goDown 0-                    True <- goUp-                    return ()-        (_, _, log) = runLoggedGo action cursor-    in log @?= ["Down 0", "Up 0"]+                    goDownOrThrow 0+                    goUpOrThrow+        result = execWriterT $ runGoT action cursor+    result @?= Right ["Down 0", "Up 0"]    , "navigates to the root of a tree, invoking handlers" ~: do     let cursor = child 0 $ child 0 $ rootCursor $@@ -191,7 +177,8 @@                  node [B $ Just (2,2)]         action = do on navigationEvent $ \step -> tell [show step]                     goToRoot-        (_, cursor', log) = runLoggedGo action cursor+        (cursor', log) = runWriter $ execGoT action cursor+    --Right (_, cursor', log) <- runLoggedGoT action cursor     cursorProperties cursor' @?= [B $ Just (0,0)]     log @?= ["GoUp 0", "GoUp 0"] @@ -237,12 +224,12 @@ positionStackTests = "position stack" ~: TestList   [ "should push, pop, and drop with no navigation" ~: do     let cursor = rootCursor $ node []-        actions = [pushPosition >> popPosition,-                   pushPosition >> pushPosition >> popPosition >> popPosition,-                   pushPosition >> dropPosition,-                   pushPosition >> pushPosition >> dropPosition >> popPosition,-                   pushPosition >> pushPosition >> popPosition >> dropPosition]-    forM_ actions $ \action -> cursorProperties (execGo action cursor) @?= []+        actions = [pushPosition >> popPositionOrThrow,+                   pushPosition >> pushPosition >> popPositionOrThrow >> popPositionOrThrow,+                   pushPosition >> dropPositionOrThrow,+                   pushPosition >> pushPosition >> dropPositionOrThrow >> popPositionOrThrow,+                   pushPosition >> pushPosition >> popPositionOrThrow >> dropPositionOrThrow]+    forM_ actions $ \action -> cursorProperties <$> execGoT action cursor @?= Right []    , "should backtrack up and down the tree" ~: do     let cursor = child 0 $ child 1 $ rootCursor $@@ -250,44 +237,44 @@                        [node1 [W $ Just (1,1)] $ node [B $ Just (2,2)],                         node1 [W Nothing] $ node [B Nothing]]         action = pushPosition >> goUp >> goUp >> goDown 0 >> goDown 0-    cursorProperties (execGo (action >> popPosition) cursor) @?= [B Nothing]-    cursorProperties (execGo (action >> dropPosition) cursor) @?= [B $ Just (2,2)]+    (cursorProperties <$> execGoT (action >> popPositionOrThrow) cursor) @?= Right [B Nothing]+    (cursorProperties <$> execGoT (action >> dropPositionOrThrow) cursor) @?= Right [B $ Just (2,2)]    , "should pop multiple stacks" ~: do     let cursor = child 0 $ child 0 commonCursor         action = do navigate-                    log >> popPosition-                    log >> popPosition+                    log >> popPositionOrThrow+                    log >> popPositionOrThrow                     log-    execWriter (runGoT action cursor) @?=-      ["B (2,2)", "B (3,3)", "B (5,5)", "B (3,3)", "B (2,2)"]+    execWriterT (runGoT action cursor) @?=+      Right ["B (2,2)", "B (3,3)", "B (5,5)", "B (3,3)", "B (2,2)"]    , "should drop then pop" ~: do     let cursor = child 0 $ child 0 commonCursor         action = do navigate-                    log >> dropPosition-                    log >> popPosition+                    log >> dropPositionOrThrow+                    log >> popPositionOrThrow                     log-    execWriter (runGoT action cursor) @?=-      ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (2,2)"]+    execWriterT (runGoT action cursor) @?=+      Right ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (2,2)"]    , "should drop twice" ~: do     let cursor = child 0 $ child 0 commonCursor         action = do navigate-                    log >> dropPosition-                    log >> dropPosition+                    log >> dropPositionOrThrow+                    log >> dropPositionOrThrow                     log-    execWriter (runGoT action cursor) @?=-      ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (5,5)"]+    execWriterT (runGoT action cursor) @?=+      Right ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (5,5)"]    , "should fire navigation handlers while popping" ~: do     let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing]         action = do pushPosition-                    True <- goDown 0-                    True <- goUp+                    goDownOrThrow 0+                    goUpOrThrow                     on navigationEvent $ \step -> tell [step]-                    popPosition-    execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0]+                    popPositionOrThrow+    execWriterT (runGoT action cursor) @?= Right [GoDown 0, GoUp 0]   ]   where commonCursor = rootCursor $                        node' [B $ Just (0,0)]@@ -300,14 +287,13 @@           [W (Just x)] -> tell ["W " ++ show x]           xs -> error $ "Unexpected properties: " ++ show xs         navigate = do log >> pushPosition-                      True <- goUp-                      True <- goDown 1+                      goUpOrThrow+                      goDownOrThrow 1                       log >> pushPosition-                      True <- goUp-                      True <- goUp-                      True <- goDown 1-                      True <- goDown 0-                      return ()+                      goUpOrThrow+                      goUpOrThrow+                      goDownOrThrow 1+                      goDownOrThrow 0  propertiesTests = "properties" ~: TestList   [ "getProperties" ~: TestList@@ -942,28 +928,28 @@     [ "basic case just not needing updating" ~:       let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]]           action = do pushPosition-                      True <- goUp+                      goUpOrThrow                       addChildAt 1 $ node [W $ Just (0,0)]-                      popPosition-      in cursorNode (execGo action cursor) @?= node [W Nothing]+                      popPositionOrThrow+      in fmap cursorNode (execGoT action cursor) @?= Right (node [W Nothing])      , "basic case just needing updating" ~:       let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]]           action = do pushPosition-                      True <- goUp+                      goUpOrThrow                       addChildAt 0 $ node [W $ Just (0,0)]-                      popPosition-      in cursorNode (execGo action cursor) @?= node [W Nothing]+                      popPositionOrThrow+      in fmap cursorNode (execGoT action cursor) @?= Right (node [W Nothing])      , "basic case definitely needing updating" ~:       let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)],                                                    node [W $ Just (1,1)]]-          action = do True <- goDown 1+          action = do goDownOrThrow 1                       pushPosition-                      True <- goUp+                      goUpOrThrow                       addChildAt 0 $ node [W Nothing]-                      popPosition-      in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)]+                      popPositionOrThrow+      in fmap cursorNode (execGoT action cursor) @?= Right (node [W $ Just (1,1)])      , "multiple paths to update" ~:       let at y x = B $ Just (y,x)@@ -971,102 +957,114 @@           level1Node i = node' [at 1 i] $ map level2Node [0..2]           level2Node i = node' [at 2 i] $ map level3Node [0..3]           level3Node i = node [at 3 i]-          action = do True <- and <$> sequence [goDown 1, goDown 2, goDown 3]+          action = do goDownOrThrow 1+                      goDownOrThrow 2+                      goDownOrThrow 3                       pushPosition-                      replicateM_ 3 goUp+                      replicateM_ 3 goUpOrThrow                       pushPosition-                      True <- and <$> sequence [goDown 1, goDown 2, goDown 2, goUp, goDown 1]+                      goDownOrThrow 1+                      goDownOrThrow 2+                      goDownOrThrow 2+                      goUpOrThrow+                      goDownOrThrow 1                       addChildAt 0 $ node1 [] $ node []-                      True <- and <$> sequence [goDown 0, goDown 0]+                      goDownOrThrow 0+                      goDownOrThrow 0                       goToRoot-                      popPosition-                      popPosition-      in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)]+                      popPositionOrThrow+                      popPositionOrThrow+      in fmap cursorNode (execGoT action $ rootCursor level0Node) @?=+         Right (node [B $ Just (3,3)])      , "updates paths with GoUp correctly" ~:       let cursor = rootCursor $ node1 [B $ Just (0,0)] $ node [W $ Just (1,1)]           action = do pushPosition-                      True <- goDown 0-                      True <- goUp+                      goDownOrThrow 0+                      goUpOrThrow                       addChildAt 0 $ node [B $ Just (2,2)]                       on navigationEvent $ \step -> tell [step]-                      popPosition-          log = execWriter (runGoT action cursor)-      in log @?= [GoDown 1, GoUp 1]+                      popPositionOrThrow+          log = execWriterT (runGoT action cursor)+      in log @?= Right ([GoDown 1, GoUp 1])     ]   ]  deleteChildAtTests = "deleteChildAt" ~: TestList   [ "ignores invalid indices" ~: do     second cursorNode (runGo (deleteChildAt 0) $ rootCursor $ node []) @?=-      (NodeDeleteBadIndex, node [])+      (Left NodeDeleteBadIndex, node [])     let base = node' [] [node [MN 0]]-    second cursorNode (runGo (deleteChildAt (-2)) $ rootCursor base) @?= (NodeDeleteBadIndex, base)-    second cursorNode (runGo (deleteChildAt (-1)) $ rootCursor base) @?= (NodeDeleteBadIndex, base)-    second cursorNode (runGo (deleteChildAt 1) $ rootCursor base) @?= (NodeDeleteBadIndex, base)-    second cursorNode (runGo (deleteChildAt 2) $ rootCursor base) @?= (NodeDeleteBadIndex, base)+    second cursorNode (runGo (deleteChildAt (-2)) $ rootCursor base) @?=+      (Left NodeDeleteBadIndex, base)+    second cursorNode (runGo (deleteChildAt (-1)) $ rootCursor base) @?=+      (Left NodeDeleteBadIndex, base)+    second cursorNode (runGo (deleteChildAt 1) $ rootCursor base) @?=+      (Left NodeDeleteBadIndex, base)+    second cursorNode (runGo (deleteChildAt 2) $ rootCursor base) @?=+      (Left NodeDeleteBadIndex, base)    , "deletes an only child" ~:     let cursor = rootCursor $ node1 [MN 0] $ node [MN 1]-        action = deleteChildAt 0-    in second cursorNode (runGo action cursor) @?= (NodeDeleteOk, node [MN 0])+        action = deleteChildAtOrThrow 0+    in fmap cursorNode (execGoT action cursor) @?= Right (node [MN 0])    , "deletes a first child" ~:     let cursor = rootCursor $ node' [MN 0] [node [MN 1], node [MN 2]]-        action = deleteChildAt 0-    in second cursorNode (runGo action cursor) @?= (NodeDeleteOk, node1 [MN 0] $ node [MN 2])+        action = deleteChildAtOrThrow 0+    in fmap cursorNode (execGoT action cursor) @?= Right (node1 [MN 0] $ node [MN 2])    , "deletes middle children" ~: do     let base = node' [MN 0] [node [MN 1], node [MN 2], node [MN 3], node [MN 4]]         cursor = rootCursor base-    second cursorNode (runGo (deleteChildAt 1) cursor) @?=-      (NodeDeleteOk, base { nodeChildren = listDeleteAt 1 $ nodeChildren base })-    second cursorNode (runGo (deleteChildAt 2) cursor) @?=-      (NodeDeleteOk, base { nodeChildren = listDeleteAt 2 $ nodeChildren base })+    fmap cursorNode (execGoT (deleteChildAtOrThrow 1) cursor) @?=+      Right (base { nodeChildren = listDeleteAt 1 $ nodeChildren base })+    fmap cursorNode (execGoT (deleteChildAtOrThrow 2) cursor) @?=+      Right (base { nodeChildren = listDeleteAt 2 $ nodeChildren base })    , "deletes a final child" ~: do     let base = node' [MN 0] [node [MN 1], node [MN 2], node [MN 3], node [MN 4]]         cursor = rootCursor base-    second cursorNode (runGo (deleteChildAt 1) cursor) @?=-      (NodeDeleteOk, base { nodeChildren = listDeleteAt 1 $ nodeChildren base })-    second cursorNode (runGo (deleteChildAt 2) cursor) @?=-      (NodeDeleteOk, base { nodeChildren = listDeleteAt 2 $ nodeChildren base })+    fmap cursorNode (execGoT (deleteChildAtOrThrow 1) cursor) @?=+      Right (base { nodeChildren = listDeleteAt 1 $ nodeChildren base })+    fmap cursorNode (execGoT (deleteChildAtOrThrow 2) cursor) @?=+      Right (base { nodeChildren = listDeleteAt 2 $ nodeChildren base })    , "fires childDeletedEvent after deleting a child" ~:     let cursor = rootCursor $ node' [MN 0] [node [MN 1], node [MN 2]]         action = do on childDeletedEvent $ tell . (:[]) . (cursorChildIndex &&& cursorNode)-                    deleteChildAt 1-    in execWriter (runGoT action cursor) @?= [(1, cursorNode $ child 1 cursor)]+                    deleteChildAtOrThrow 1+    in execWriterT (runGoT action cursor) @?= Right [(1, cursorNode $ child 1 cursor)]    , "path stack correctness" ~: TestList     [ "basic case just not needing updating" ~:       let cursor = rootCursor $ node' [B Nothing] [node [W Nothing], node [W $ Just (0,0)]]-          action = do True <- goDown 0+          action = do goDownOrThrow 0                       pushPosition-                      True <- goUp-                      NodeDeleteOk <- deleteChildAt 1-                      popPosition-      in cursorNode (execGo action cursor) @?= node [W Nothing]+                      goUpOrThrow+                      deleteChildAtOrThrow 1+                      popPositionOrThrow+      in fmap cursorNode (execGoT action cursor) @?= Right (node [W Nothing])      , "basic case just needing updating" ~:       let cursor = rootCursor $ node' [B Nothing] [node [W Nothing], node [W $ Just (0,0)]]-          action = do True <- goDown 1+          action = do goDownOrThrow 1                       pushPosition-                      True <- goUp-                      NodeDeleteOk <- deleteChildAt 0-                      popPosition-      in cursorNode (execGo action cursor) @?= node [W $ Just (0,0)]+                      goUpOrThrow+                      deleteChildAtOrThrow 0+                      popPositionOrThrow+      in fmap cursorNode (execGoT action cursor) @?= Right (node [W $ Just (0,0)])      , "basic case definitely needing updating" ~:       let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)],                                                    node [W $ Just (1,1)],                                                    node [W $ Just (2,2)]]-          action = do True <- goDown 2+          action = do goDownOrThrow 2                       pushPosition-                      True <- goUp-                      NodeDeleteOk <- deleteChildAt 0-                      popPosition-      in cursorNode (execGo action cursor) @?= node [W $ Just (2,2)]+                      goUpOrThrow+                      deleteChildAtOrThrow 0+                      popPositionOrThrow+      in fmap cursorNode (execGoT action cursor) @?= Right (node [W $ Just (2,2)])      , "multiple paths to update" ~:       let at y x = B $ Just (y,x)@@ -1074,37 +1072,40 @@           level1Node i = node' [at 1 i] $ map level2Node [0..2]           level2Node i = node' [at 2 i] $ map level3Node [0..3]           level3Node i = node [at 3 i]-          action = do True <- and <$> sequence [goDown 1, goDown 2, goDown 3]+          action = do goDownOrThrow 1+                      goDownOrThrow 2+                      goDownOrThrow 3                       pushPosition-                      True <- goUp-                      NodeDeleteOk <- deleteChildAt 1+                      goUpOrThrow+                      deleteChildAtOrThrow 1                       pushPosition                       goToRoot-                      True <- goDown 0-                      True <- goDown 2+                      goDownOrThrow 0+                      goDownOrThrow 2                       pushPosition-                      True <- goUp-                      NodeDeleteOk <- deleteChildAt 0+                      goUpOrThrow+                      deleteChildAtOrThrow 0                       goToRoot-                      True <- goDown 1-                      True <- goDown 2-                      NodeDeleteOk <- deleteChildAt 1+                      goDownOrThrow 1+                      goDownOrThrow 2+                      deleteChildAtOrThrow 1                       replicateM_ 3 popPosition-      in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)]+      in fmap cursorNode (execGoT action $ rootCursor level0Node) @?=+         Right (node [B $ Just (3,3)])      , "returns an error if a node to delete is on the path stack" ~:       let base = node' [B $ Just (0,0)] [node [W $ Just (1,1)],                                          node [W $ Just (2,2)]]-          action = do True <- goDown 1+          action = do goDownOrThrow 1                       pushPosition-                      True <- goUp+                      goUpOrThrow                       pushPosition-                      True <- goDown 0+                      goDownOrThrow 0                       pushPosition-                      True <- goUp-                      deleteChildAt 1-      in second cursorNode (runGo action $ rootCursor base) @?=-         (NodeDeleteOnPathStack, base)+                      goUpOrThrow+                      deleteChildAt 1  -- Note, nonthrowing.+      in fmap (second cursorNode) (runGoT action $ rootCursor base) @?=+         Right (Left NodeDeleteOnPathStack, base)     ]   ] @@ -1114,30 +1115,28 @@                  node1 [B $ Just (0,0)] $                  node [W $ Just (0,0), GN $ toSimpleText "Foo"]         action = do on gameInfoChangedEvent onInfo-                    True <- goDown 0-                    return ()-    in execWriter (runGoT action cursor) @?= [(Nothing, Just $ toSimpleText "Foo")]+                    goDownOrThrow 0+    in execWriterT (runGoT action cursor) @?= Right [(Nothing, Just $ toSimpleText "Foo")]    , "fires when navigating up" ~:     let cursor = child 0 $ rootCursor $                  node1 [B $ Just (0,0)] $                  node [W $ Just (0,0), GN $ toSimpleText "Foo"]         action = do on gameInfoChangedEvent onInfo-                    True <- goUp-                    return ()-    in execWriter (runGoT action cursor) @?= [(Just $ toSimpleText "Foo", Nothing)]+                    goUpOrThrow+    in execWriterT (runGoT action cursor) @?= Right [(Just $ toSimpleText "Foo", Nothing)]    , "fires from within popPosition" ~:     let cursor = rootCursor $                  node1 [B $ Just (0,0)] $                  node [W $ Just (0,0), GN $ toSimpleText "Foo"]         action = do pushPosition-                    True <- goDown 0-                    True <- goUp+                    goDownOrThrow 0+                    goUpOrThrow                     on gameInfoChangedEvent onInfo-                    popPosition-    in execWriter (runGoT action cursor) @?=-       [(Nothing, Just $ toSimpleText "Foo"), (Just $ toSimpleText "Foo", Nothing)]+                    popPositionOrThrow+    in execWriterT (runGoT action cursor) @?=+       Right [(Nothing, Just $ toSimpleText "Foo"), (Just $ toSimpleText "Foo", Nothing)]    , "fires when modifying properties" ~:     let cursor = rootCursor $ node []

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -24,9 +24,6 @@   assertNoParse,   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<*))-#endif import Game.Goatee.Lib.Parser import Game.Goatee.Lib.Tree import Test.HUnit (assertFailure)

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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@@ -19,9 +19,6 @@  module Game.Goatee.Lib.Property.ParserTest (tests) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif import Control.Monad (forM_) import Data.Maybe (catMaybes) import Game.Goatee.Common

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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

@@ -1,6 +1,6 @@ -- This file is part of Goatee. ----- Copyright 2014-2018 Bryan Gardiner+-- 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