goatee-0.3.1: tests/Game/Goatee/Lib/MonadTest.hs
-- This file is part of Goatee.
--
-- Copyright 2014-2015 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, FlexibleContexts #-}
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 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
import Game.Goatee.Lib.Monad
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.TestInstances ()
import Game.Goatee.Lib.TestUtils
import Game.Goatee.Lib.Tree (emptyNode, nodeChildren)
import Game.Goatee.Lib.Types
import Game.Goatee.Test.Common
import Test.HUnit ((~:), (@=?), (@?=), Assertion, Test (TestList), assertFailure)
{-# 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
, positionStackTests
, propertiesTests
, getPropertyTests
, getPropertyValueTests
, putPropertyTests
, deletePropertyTests
, modifyPropertyTests
, modifyPropertyValueTests
, modifyPropertyStringTests
, modifyPropertyListTests
, modifyPropertyCoordsTests
, modifyGameInfoTests
, modifyVariationModeTests
, getAssignedStoneTests
, getAllAssignedStonesTests
, modifyAssignedStonesTests
, getMarkTests
, modifyMarkTests
, addChildTests
, addChildAtTests
, deleteChildAtTests
, gameInfoChangedTests
]
monadTests = "monad properties" ~: TestList
[ "returns a value it's given" ~:
let cursor = rootCursor $ node []
(value, cursor') = runGo (return 3) cursor
in (value, cursorNode cursor') @?= (3, cursorNode cursor)
, "getCursor works" ~: do
let cursor = rootCursor nodeA
nodeA = node1 [SZ 3 3, B $ Just (0,0)] nodeB
nodeB = node1 [W $ Just (1,1)] nodeC
nodeC = node [B $ Just (2,2)]
nodeA @=? evalGo (liftM cursorNode getCursor) cursor
nodeB @=? evalGo (goDown 0 >> liftM cursorNode getCursor) cursor
nodeC @=? evalGo (goDown 0 >> goDown 0 >> liftM cursorNode getCursor) cursor
, "getCoordState works" ~: do
let cursor = child 0 $ child 0 $ rootCursor $
node1 [SZ 2 2, B $ Just (0,0)] $
node1 [W $ Just (1,0), TR $ coord1 (0,0)] $
node [B $ Just (0,1), CR $ coord1 (1,0)]
action = mapM getCoordState [(0,0), (1,0), (0,1), (1,1)]
states = evalGo action cursor
map coordStone states @?= [Just Black, Just White, Just Black, Nothing]
map coordMark states @?= [Nothing, Just MarkCircle, Nothing, Nothing]
]
navigationTests = "navigation" ~: TestList
[ "navigates down a tree" ~: do
let cursor = rootCursor $
node1 [B $ Just (0,0)] $
node' [W $ Just (1,1)] [node [B $ Just (2,2)],
node [B Nothing]]
action = do tell . (:[]) =<< goDown 0
tell . (:[]) =<< goDown 1
tell . (:[]) =<< goDown 0
((_, cursor'), log) = runWriter $ runGoT action cursor
cursorProperties cursor' @?= [B Nothing]
log @?= [True, True, False]
, "navigates up a tree" ~: do
let cursor = child 1 $ child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node' [W $ Just (1,1)] [node [B $ Just (2,2)],
node [B Nothing]]
action = replicateM_ 3 (tell . (:[]) =<< goUp)
((_, cursor'), log) = runWriter $ runGoT action cursor
cursorProperties cursor' @?= [B $ Just (0,0)]
log @?= [True, True, False]
, "navigates to the left" ~:
let cursor = child 2 $ child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node' [W $ Just (1,1)]
[node [B $ Just (2,2)],
node [B $ Just (3,3)],
node [B $ Just (4,4)]]
action = do tell . (:[]) . show =<< goLeft
tell . (:[]) . show =<< getProperties
tell . (:[]) . show =<< goLeft
tell . (:[]) . show =<< getProperties
tell . (:[]) . show =<< goLeft
tell . (:[]) . show =<< getProperties
log = execWriter $ runGoT action cursor
in log @?= ["True",
"[B (Just (3,3))]",
"True",
"[B (Just (2,2))]",
"False",
"[B (Just (2,2))]"]
, "navigates to the right" ~:
let cursor = child 0 $ child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node' [W $ Just (1,1)]
[node [B $ Just (2,2)],
node [B $ Just (3,3)],
node [B $ Just (4,4)]]
action = do tell . (:[]) . show =<< goRight
tell . (:[]) . show =<< getProperties
tell . (:[]) . show =<< goRight
tell . (:[]) . show =<< getProperties
tell . (:[]) . show =<< goRight
tell . (:[]) . show =<< getProperties
log = execWriter $ runGoT action cursor
in log @?= ["True",
"[B (Just (3,3))]",
"True",
"[B (Just (4,4))]",
"False",
"[B (Just (4,4))]"]
, "invokes handlers when navigating" ~:
let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing]
action = do on navigationEvent $ \step -> case step of
GoUp index -> tell ["Up " ++ show index]
_ -> return ()
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"]
, "navigates to the root of a tree, invoking handlers" ~: do
let cursor = child 0 $ child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node1 [W $ Just (1,1)] $
node [B $ Just (2,2)]
action = do on navigationEvent $ \step -> tell [show step]
goToRoot
(_, cursor', log) = runLoggedGo action cursor
cursorProperties cursor' @?= [B $ Just (0,0)]
log @?= ["GoUp 0", "GoUp 0"]
, "goToGameInfoNode" ~: TestList
[ "can navigate up to find game info" ~:
let props = [PB (toSimpleText ""), B Nothing]
cursor = child 0 $ rootCursor $ node1 props $ node [W Nothing]
action = void $ goToGameInfoNode False
in cursorProperties (execGo action cursor) @?= props
, "can find game info at the current node" ~:
let props = [PB (toSimpleText ""), W Nothing]
cursor = child 0 $ rootCursor $ node1 [B Nothing] $ node props
action = void $ goToGameInfoNode False
in cursorProperties (execGo action cursor) @?= props
, "doesn't find game info from a subnode" ~:
let cursor = child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node1 [W $ Just (1,1)] $
node [PB (toSimpleText ""), B Nothing]
action = void $ goToGameInfoNode False
in cursorProperties (execGo action cursor) @?= [W $ Just (1,1)]
, "can return to the initial node when no game info is found" ~:
let cursor = child 0 $ child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node1 [W $ Just (1,1)] $
node [B $ Just (2,2)]
action = void $ goToGameInfoNode False
in cursorProperties (execGo action cursor) @?= [B $ Just (2,2)]
, "can finish at the root node when no game info is found" ~:
let cursor = child 0 $ child 0 $ rootCursor $
node1 [B $ Just (0,0)] $
node1 [W $ Just (1,1)] $
node [B $ Just (2,2)]
action = void $ goToGameInfoNode True
in cursorProperties (execGo action cursor) @?= [B $ Just (0,0)]
]
]
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) @?= []
, "should backtrack up and down the tree" ~: do
let cursor = child 0 $ child 1 $ rootCursor $
node' [B $ Just (0,0)]
[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)]
, "should pop multiple stacks" ~: do
let cursor = child 0 $ child 0 commonCursor
action = do navigate
log >> popPosition
log >> popPosition
log
execWriter (runGoT action cursor) @?=
["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
execWriter (runGoT action cursor) @?=
["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
execWriter (runGoT action cursor) @?=
["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
on navigationEvent $ \step -> tell [step]
popPosition
execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0]
]
where commonCursor = rootCursor $
node' [B $ Just (0,0)]
[node' [W $ Just (1,1)]
[node [B $ Just (2,2)],
node [B $ Just (3,3)]],
node1 [W $ Just (4,4)] $ node [B $ Just (5,5)]]
log = getCursor >>= \cursor -> case cursorProperties cursor of
[B (Just x)] -> tell ["B " ++ show x]
[W (Just x)] -> tell ["W " ++ show x]
xs -> error $ "Unexpected properties: " ++ show xs
navigate = do log >> pushPosition
True <- goUp
True <- goDown 1
log >> pushPosition
True <- goUp
True <- goUp
True <- goDown 1
True <- goDown 0
return ()
propertiesTests = "properties" ~: TestList
[ "getProperties" ~: TestList
[ "returns an empty list" ~:
let cursor = rootCursor $ node []
in evalGo getProperties cursor @?= []
, "returns a non-empty list" ~:
let properties = [PB $ toSimpleText "Foo", B Nothing]
cursor = rootCursor $ node properties
in evalGo getProperties cursor @?= properties
]
, "modifyProperties" ~: TestList
[ "adds properties" ~:
let cursor = rootCursor $ node [FF 1]
action = do modifyProperties $ \props -> props ++ [B Nothing, W Nothing]
getProperties
in evalGo action cursor @?= [FF 1, B Nothing, W Nothing]
, "removes properties" ~:
let cursor = rootCursor $ node [W Nothing, FF 1, B Nothing]
action = do modifyProperties $ \props -> filter (not . isMoveProperty) props
getProperties
in evalGo action cursor @?= [FF 1]
, "fires a properties modified event" ~:
let cursor = rootCursor $ node [FF 1]
action = do on propertiesModifiedEvent $ \old new -> tell [(old, new)]
modifyProperties $ const [FF 2]
log = execWriter (runGoT action cursor)
in log @?= [([FF 1], [FF 2])]
]
]
where isMoveProperty prop = case prop of
B _ -> True
W _ -> True
_ -> False
getPropertyTests = "getProperty" ~: TestList
[ "doesn't find an unset property" ~: do
Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [])
Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [B Nothing])
, "finds a set property" ~: do
Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing])
Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing, DO])
Just DO @=? evalGo (getProperty propertyDO) (rootCursor $ node [B Nothing, DO])
]
getPropertyValueTests = "getPropertyValue" ~: TestList
[ "doesn't find an unset property" ~: do
Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [])
Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [B Nothing])
, "finds a set property" ~: do
Just Nothing @=? evalGo (getPropertyValue propertyB) (rootCursor $ node [B Nothing])
Just (Just (0,0)) @=?
evalGo (getPropertyValue propertyB) (rootCursor $ node [B $ Just (0,0), TE Double1])
Just Double1 @=?
evalGo (getPropertyValue propertyTE) (rootCursor $ node [B $ Just (0,0), TE Double1])
]
putPropertyTests = "putProperty" ~: TestList
[ "adds an unset property" ~: do
[IT] @=? cursorProperties (execGo (putProperty IT) $ rootCursor $ node [])
[DO, IT] @=?
sortProperties (cursorProperties (execGo (putProperty IT) $ rootCursor $ node [DO]))
, "replaces an existing property" ~:
[TE Double2] @=?
cursorProperties (execGo (putProperty $ TE Double2) (rootCursor $ node [TE Double1]))
]
deletePropertyTests = "deleteProperty" ~: TestList
[ "does nothing when the property isn't set" ~: do
[] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [])
[B Nothing] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [B Nothing])
, "removes a property" ~: do
[] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [DO])
-- This is documented behaviour for deleteProperty, the fact that it doesn't
-- matter what the property value is:
[DO] @=? cursorProperties
(execGo (deleteProperty $ B $ Just (0,0)) $ rootCursor $ node [DO, B Nothing])
]
modifyPropertyTests = "modifyProperty" ~: TestList
[ "adds a property to an empty node" ~:
let cursor = rootCursor $ node []
action = modifyProperty propertyIT (\Nothing -> Just IT)
in cursorProperties (execGo action cursor) @?= [IT]
, "adds a property to a non-empty node" ~:
let cursor = rootCursor $ node [KO]
action = modifyProperty propertyIT (\Nothing -> Just IT)
in sortProperties (cursorProperties $ execGo action cursor) @?= [IT, KO]
, "removes a property" ~: do
let cursor = rootCursor $ node [IT, KO]
cursor' = execGo (modifyProperty propertyKO $ \(Just KO) -> Nothing) cursor
cursor'' = execGo (modifyProperty propertyIT $ \(Just IT) -> Nothing) cursor'
cursorProperties cursor' @?= [IT]
cursorProperties cursor'' @?= []
, "updates a property" ~: do
let cursor = rootCursor $ node [B $ Just (0,0), BM Double2]
action = modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Just $ B $ Just (1,1)
cursor' = execGo action cursor
action' = modifyProperty propertyBM $ \(Just (BM Double2)) -> Just $ BM Double1
cursor'' = execGo action' cursor'
sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2]
sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1]
, "fires an event when modifying a property" ~: do
let cursor = rootCursor $ node [B $ Just (0,0)]
action = do on propertiesModifiedEvent $ \[B (Just (0,0))] [] -> tell [0]
modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Nothing
(cursor', log) = runWriter (execGoT action cursor)
[0] @=? log
[] @=? cursorProperties cursor'
, "modifying but not actually changing a property doesn't fire an event" ~: do
let cursor = rootCursor $ node [B $ Just (0,0)]
action = do on propertiesModifiedEvent $ \_ _ -> tell ["Event fired."]
modifyProperty propertyB $ \p@(Just (B {})) -> p
(cursor', log) = runWriter (execGoT action cursor)
[B $ Just (0,0)] @=? cursorProperties cursor'
[] @=? log
]
modifyPropertyValueTests = "modifyPropertyValue" ~: TestList
[ "adds a property to an empty node" ~:
let cursor = rootCursor $ node []
action = modifyPropertyValue propertyPL (\Nothing -> Just Black)
in cursorProperties (execGo action cursor) @?= [PL Black]
, "adds a property to a non-empty node" ~:
let cursor = rootCursor $ node [KO]
action = modifyPropertyValue propertyPL (\Nothing -> Just White)
in sortProperties (cursorProperties $ execGo action cursor) @?= [KO, PL White]
, "removes a property" ~: do
let cursor = rootCursor $ node [B Nothing, TE Double2]
cursor' = execGo (modifyPropertyValue propertyTE $ \(Just Double2) -> Nothing) cursor
cursor'' = execGo (modifyPropertyValue propertyB $ \(Just Nothing) -> Nothing) cursor'
cursorProperties cursor' @?= [B Nothing]
cursorProperties cursor'' @?= []
, "updates a property" ~: do
let cursor = rootCursor $ node [B $ Just (0,0), BM Double2]
action = modifyPropertyValue propertyB $ \(Just (Just (0,0))) -> Just $ Just (1,1)
cursor' = execGo action cursor
action' = modifyPropertyValue propertyBM $ \(Just Double2) -> Just Double1
cursor'' = execGo action' cursor'
sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2]
sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1]
]
modifyPropertyStringTests =
"modifyPropertyString" ~: TestList $
-- Test a Text property and a SimpleText property.
assumptions ++ genTests "comment" propertyC ++ genTests "game name" propertyGN
where assumptions = let _ = C $ toText ""
_ = GN $ toSimpleText ""
in []
genTests name property =
[ "adds a " ++ name ~:
let cursor = rootCursor $ node []
action = modifyPropertyString property (++ "Hello.")
in cursorProperties (execGo action cursor) @?=
[propertyBuilder property $ stringToSgf "Hello."]
, "removes a " ++ name ~:
let cursor = rootCursor $ node [propertyBuilder property $ stringToSgf "Hello."]
action = modifyPropertyString property $ \value -> case value of
"Hello." -> ""
other -> error $ "Got: " ++ other
in cursorProperties (execGo action cursor) @?= []
, "updates a " ++ name ~:
let cursor = child 0 $ rootCursor $
node1 [propertyBuilder property $ stringToSgf "one"] $
node [propertyBuilder property $ stringToSgf "two"]
action = modifyPropertyString property $ \value -> case value of
"two" -> "three"
other -> error $ "Got: " ++ other
cursor' = execGo action cursor
in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?=
([propertyBuilder property $ stringToSgf "three"],
[propertyBuilder property $ stringToSgf "one"])
, "leaves a non-existant comment" ~:
let result = execGo (modifyPropertyString property id) $ rootCursor $ node []
in cursorProperties result @?= []
]
modifyPropertyListTests = "modifyPropertyList" ~: TestList
[ "adds a property where there was none" ~:
let cursor = rootCursor $ node []
arrows = [((0,0), (1,1)), ((0,1), (1,0))]
action = modifyPropertyList propertyAR $ \[] -> arrows
in [AR arrows] @=? cursorProperties (execGo action cursor)
, "removes a property where there was one" ~:
let lines = [Line (0,0) (0,1), Line (1,0) (1,1)]
cursor = rootCursor $ node [LN lines]
action = modifyPropertyList propertyLN $ \old ->
if old == lines then [] else error $ "Unexpected old value: " ++ show old
in [] @=? cursorProperties (execGo action cursor)
, "modifies an existing property" ~:
let lines = [Line (0,0) (0,1), Line (1,0) (1,1)]
lines' = [head lines]
cursor = rootCursor $ node [LN lines]
action = modifyPropertyList propertyLN $ \old ->
if old == lines then lines' else error $ "Unexpected old value: " ++ show old
in [LN lines'] @=? cursorProperties (execGo action cursor)
, "fires propertiesModifiedEvent when changed" ~:
let lines = [Line (0,0) (0,1), Line (1,0) (1,1)]
lines' = [head lines]
cursor = rootCursor $ node [LN lines]
action = do
on propertiesModifiedEvent $ \old new -> tell [(old, new)]
modifyPropertyList propertyLN $ \old ->
if old == lines then lines' else error $ "Unexpected old value: " ++ show old
in [([LN lines], [LN lines'])] @=? execWriter (runGoT action cursor)
, "doesn't fire propertiesModifiedEvent when not changed" ~:
let lines = [Line (0,0) (0,1), Line (1,0) (1,1)]
cursor = rootCursor $ node [LN lines]
action = do
on propertiesModifiedEvent $ \old new -> tell [(old, new)]
modifyPropertyList propertyLN id
in [] @=? execWriter (runGoT action cursor)
]
modifyPropertyCoordsTests = "modifyPropertyCoords" ~: TestList
[ "adds a property where there was none" ~:
let cursor = rootCursor $ node []
action = modifyPropertyCoords propertySL $ \[] -> [(0,0), (1,1)]
in [SL $ coords [(0,0), (1,1)]] @=? cursorProperties (execGo action cursor)
, "removes a property where there was one" ~:
let cursor = rootCursor $ node [TR $ coord1 (5,5)]
action = modifyPropertyCoords propertyTR $ \[(5,5)] -> []
in [] @=? cursorProperties (execGo action cursor)
, "modifies an existing property" ~:
let cursor = rootCursor $ node [CR $ coord1 (3,4)]
action = modifyPropertyCoords propertyCR $ \[(3,4)] -> [(2,2)]
in [CR $ coord1 (2,2)] @=? cursorProperties (execGo action cursor)
, "doesn't affect other properties" ~:
let cursor = rootCursor $ node [SQ $ coord1 (0,0), MA $ coord1 (1,1)]
action = modifyPropertyCoords propertyMA $ \[(1,1)] -> [(2,2)]
in [MA $ coord1 (2,2), SQ $ coord1 (0,0)] @=?
sortProperties (cursorProperties $ execGo action cursor)
]
modifyGameInfoTests = "modifyGameInfo" ~: TestList
[ "creates info on the root node, starting with none" ~: TestList
[ "starting from the root node" ~:
let cursor = rootCursor $ node []
action = modifyGameInfo $ \info ->
info { gameInfoGameName = Just $ toSimpleText "Orange" }
in cursorProperties (execGo action cursor) @?= [GN $ toSimpleText "Orange"]
, "starting from a non-root node" ~:
let cursor = child 0 $ rootCursor $ node1 [] $ node [B Nothing]
action = modifyGameInfo $ \info ->
info { gameInfoGameName = Just $ toSimpleText "Orange" }
cursor' = execGo action cursor
in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?=
([B Nothing], [GN $ toSimpleText "Orange"])
]
, "modifies existing info on the root" ~: TestList
[ "starting from the root node" ~:
let cursor = rootCursor $ node [GN $ toSimpleText "Orange"]
action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing
, gameInfoBlackName =
Just $ toSimpleText "Peanut butter"
})
in cursorProperties (execGo action cursor) @?= [PB $ toSimpleText "Peanut butter"]
, "starting from a non-root node" ~:
let cursor = child 0 $ rootCursor $ node1 [GN $ toSimpleText "Orange"] $ node [B Nothing]
action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing
, gameInfoBlackName =
Just $ toSimpleText "Peanut butter"
})
cursor' = execGo action cursor
in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?=
([B Nothing], [PB $ toSimpleText "Peanut butter"])
]
, "moves game info from a non-root node to the root" ~:
let cursor = child 0 $ child 0 $ child 0 $ rootCursor $
node1 [SZ 19 19] $
node1 [B $ Just (0,0), GN $ toSimpleText "Orange"] $
node1 [W $ Just (1,1)] $
node [B $ Just (2,2)]
action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing })
cursor' = execGo action cursor
action' = modifyGameInfo (\info -> info { gameInfoBlackName =
Just $ toSimpleText "Peanut butter" })
cursor'' = execGo action' cursor'
-- unfoldr :: (Maybe Cursor -> Maybe ([Property], Maybe Cursor))
-- -> Maybe Cursor
-- -> [[Property]]
properties = unfoldr (fmap $ cursorProperties &&& cursorParent)
(Just cursor'')
in map sortProperties properties @?=
[[B $ Just (2,2)],
[W $ Just (1,1)],
[B $ Just (0,0)],
[PB $ toSimpleText "Peanut butter", SZ 19 19]]
]
modifyVariationModeTests = "modifyVariationMode" ~: TestList
[ "testing modes are not default" ~: do
defaultVariationMode @/=? mode
defaultVariationMode @/=? mode2
, "modifies when at a root node" ~:
node1 [ST mode] (node []) @=?
cursorNode (execGo setMode $ rootCursor $ node1 [] $ node [])
, "modifies when at a non-root node" ~:
node1 [ST mode] (node []) @=?
cursorNode (cursorRoot $ execGo setMode $ child 0 $ rootCursor $ node1 [] $ node [])
, "leaves an unset ST unset" ~:
assertST Nothing Nothing $ const defaultVariationMode
, "leaves a default ST alone" ~:
assertST (Just defaultVariationMode) (Just defaultVariationMode) $ const defaultVariationMode
, "leaves an existing ST alone" ~:
assertST (Just mode) (Just mode) $ const mode
, "adds an ST property" ~:
assertST (Just mode) Nothing $ const mode
, "removes an ST property when setting to default" ~:
assertST Nothing (Just mode) $ const defaultVariationMode
, "modifies an existing ST property" ~:
assertST (Just mode2) (Just mode) $ const mode2
]
where mode = VariationMode ShowCurrentVariations True
mode2 = VariationMode ShowChildVariations False
setMode = modifyVariationMode $ const mode
assertST maybeExpectedST maybeInitialST fn =
node (ST <$> maybeToList maybeExpectedST) @=?
cursorNode (execGo (modifyVariationMode fn) $
rootCursor $ node $ ST <$> maybeToList maybeInitialST)
getAssignedStoneTests = "getAssignedStone" ~: TestList
[ "should return Nothing for a point without an assignment" ~:
evalGo (getAssignedStone (0,0)) cursor @?= Nothing
, "should return Nothing for an assignment in a parent node" ~:
evalGo (getAssignedStone (1,0)) cursor @?= Nothing
, "should return Just for assigned points" ~: do
evalGo (getAssignedStone (2,0)) cursor @?= Just (Just Black)
evalGo (getAssignedStone (3,0)) cursor @?= Just (Just White)
evalGo (getAssignedStone (4,0)) cursor @?= Just Nothing
]
where cursor = child 0 $ rootCursor $
root 5 1 [AB $ coord1 (1,0),
AW $ coord1 (4,0)]
[node [AB $ coord1 (2,0),
AW $ coord1 (3,0),
AE $ coord1 (4,0)]]
getAllAssignedStonesTests = "getAllAssignedStones" ~: TestList
[ "returns empty given no stone assignments" ~: do
Map.empty @=? evalGo getAllAssignedStones (rootCursor $ node [])
Map.empty @=? evalGo getAllAssignedStones (rootCursor $ node [B $ Just (0,0)])
, "ignores stone assignments in a parent node" ~:
Map.empty @=?
evalGo getAllAssignedStones (child 0 $ rootCursor $ root 1 1 [AB $ coord1 (0,0)] [node []])
, "finds a single stone assignment" ~:
Map.fromList [((0,0), Just Black)] @=?
evalGo getAllAssignedStones (rootCursor $ root 1 1 [AB $ coord1 (0,0)] [])
, "finds multiple stone assignments" ~:
Map.fromList [((0,0), Just Black),
((1,0), Just Black),
((3,0), Just White),
((4,0), Nothing),
((5,0), Just Black)] @=?
evalGo getAllAssignedStones (rootCursor $
root 6 1 [AB $ buildCoordList [(0,0), (1,0), (5,0)],
AW $ coord1 (3,0),
AE $ coord1 (4,0)]
[])
]
modifyAssignedStonesTests = "modifyAssignedStones" ~: TestList
[ "adds assignments to a node without" ~:
forM_ [Nothing, Just Black, Just White] $ \stone ->
test (rootCursor $ root 2 2 [] [])
(do modifyAssignedStones [(1,1)] $ const $ Just stone
getAllAssignedStones)
(Map.fromList [((1,1), stone)])
noLogAssertion
, "adds assignments to a node with existing assignments of the same type" ~:
test (rootCursor $ root 2 2 [AE $ coord1 (0,0)] [])
(do modifyAssignedStones [(0,1), (1,1)] $ const $ Just Nothing
getAllAssignedStones)
(Map.fromList [((0,0), Nothing), ((0,1), Nothing), ((1,1), Nothing)])
noLogAssertion
, "adds assignments to a node with existing assignments of a different type" ~:
test (rootCursor $ root 2 2 [AE $ coord1 (0,0)] [])
(do modifyAssignedStones [(0,1), (1,1)] $ const $ Just $ Just White
getAllAssignedStones)
(Map.fromList [((0,0), Nothing), ((0,1), Just White), ((1,1), Just White)])
noLogAssertion
, "assigning overwrites overlapping assignments of a different type" ~:
test (rootCursor $ root 2 2 [AE $ coord1 (0,0), AB $ coord1 (0,1), AW $ coord1 (1,1)] [])
(do modifyAssignedStones [(0,0), (0,1), (1,0), (1,1)] $ const $ Just $ Just White
getAllAssignedStones)
(Map.fromList $ (\coord -> (coord, Just White)) <$> [(0,0), (0,1), (1,0), (1,1)])
noLogAssertion
, "fires propertiesModifiedEvents when assignments change" ~:
test (rootCursor $ root 2 2 [AE $ coord1 (0,0), AB $ coord1 (0,1), AW $ coord1 (1,1)] [])
(do logPropertyChanges
modifyAssignedStones [(0,0), (0,1), (1,0), (1,1)] $ \old -> case old of
Just (Just color) -> Just $ Just $ cnot color
_ -> old)
()
(Just $ \log -> case log of
-- Expect two events, since we're swapping AB and AW. But don't
-- expect them in a particular order; just assert the start and end
-- states.
[(initial, _), (_, final)] ->
(initial, final) @=? ([AB $ coord1 (0,1), AE $ coord1 (0,0), AW $ coord1 (1,1)],
[AB $ coord1 (1,1), AE $ coord1 (0,0), AW $ coord1 (0,1)])
_ -> assertFailure $ "Expected two events: " ++ show log)
, "doesn't fire a propertiesModifiedEvent when assignments don't change" ~:
test (rootCursor $ root 2 2 [AE $ coord1 (0,0), AB $ coord1 (0,1), AW $ coord1 (1,1)] [])
(do on propertiesModifiedEvent $ \old new ->
tell [(sortBy (comparing propertyName) $
filter ((`elem` ["AB", "AE", "AW"]) . propertyName) old,
sortBy (comparing propertyName) $
filter ((`elem` ["AB", "AE", "AW"]) . propertyName) new)]
modifyAssignedStones [(0,0), (0,1), (1,0), (1,1)] id)
()
(Just (@?= []))
, "creates a child if the current node has a move property with no setup property" ~:
test (rootCursor $ root 2 1 [B $ Just (0,0)] [])
(do modifyAssignedStones [(1,0)] $ const $ Just $ Just White
goToRoot
cursorNode <$> getCursor)
(root 2 1 [B $ Just (0,0)] [node [AW $ coord1 (1,0)]])
noLogAssertion
, "doesn't create a child if the current node has a move property and a setup property" ~:
test (rootCursor $ root 3 1 [B $ Just (0,0), AB $ coord1 (1,0)] [])
(do logEventNames
modifyAssignedStones [(2,0)] $ const $ Just $ Just White
cursorNode <$> getCursor)
(root 3 1 [B $ Just (0,0), AB $ coord1 (1,0), AW $ coord1 (2,0)] [])
(Just (@?= ["Properties modified."]))
, "fires the correct events when the current node has a move property" ~:
test (rootCursor $ root 2 1 [B $ Just (0,0)] [])
(do logEventNames
modifyAssignedStones [(1,0)] $ const $ Just $ Just White)
()
-- No propertiesModifiedEvent is fired: the child is added with the
-- assignment property already present.
(Just (@?= ["Child added.", "Navigated."]))
]
where test :: (Eq a, Show a, Eq b, Monoid b, Show b)
=> Cursor
-> GoT (Writer b) a
-> a
-> Maybe (b -> Assertion)
-> Assertion
test cursor action expected maybeLogAssertion = do
let (actual, log) = runWriter $ evalGoT action cursor
expected @=? actual
whenMaybe maybeLogAssertion ($ log)
logPropertyChanges :: GoT (Writer [([Property], [Property])]) ()
logPropertyChanges =
on propertiesModifiedEvent $ \old new ->
tell [(sortBy (comparing propertyName) $
filter ((`elem` ["AB", "AE", "AW"]) . propertyName) old,
sortBy (comparing propertyName) $
filter ((`elem` ["AB", "AE", "AW"]) . propertyName) new)]
logEventNames :: GoT (Writer [String]) ()
logEventNames = do
on0 childAddedEvent $ tell ["Child added."]
on0 navigationEvent $ tell ["Navigated."]
on0 propertiesModifiedEvent $ tell ["Properties modified."]
noLogAssertion :: Maybe (() -> Assertion)
noLogAssertion = Nothing
getMarkTests = "getMark" ~: TestList
[ "returns Nothing for no mark" ~: do
Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [])
Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [W $ Just (0,0)])
, "returns Just when a mark is present" ~: do
Just MarkSquare @=? evalGo (getMark (1,2)) (rootCursor $ node [SQ $ coord1 (1,2)])
Just MarkTriangle @=? evalGo (getMark (1,1)) (rootCursor $ node [B $ Just (1,1),
TR $ coord1 (1,1),
SQ $ coord1 (1,2)])
, "matches all marks" ~: forM_ [minBound..maxBound] $ \mark ->
Just mark @=?
evalGo (getMark (0,0))
(rootCursor $ node [propertyBuilder (markProperty mark) $ coord1 (0,0)])
]
modifyMarkTests = "modifyMark" ~: TestList
[ "creates a mark where there was none" ~:
let cursor = rootCursor $ node []
action = do modifyMark (\Nothing -> Just MarkX) (0,0)
getMark (0,0)
in Just MarkX @=? evalGo action cursor
, "removes an existing mark" ~:
let cursor = rootCursor $ node [CR $ coord1 (0,0)]
action = do modifyMark (\(Just MarkCircle) -> Nothing) (0,0)
getMark (0,0)
in Nothing @=? evalGo action cursor
, "replaces an existing mark" ~:
let cursor = rootCursor $ node [CR $ coord1 (0,0)]
action = do modifyMark (\(Just MarkCircle) -> Just MarkX) (0,0)
getMark (0,0)
in Just MarkX @=? evalGo action cursor
, "adds on to an existing mark property" ~:
let cursor = rootCursor $ node [MA $ coord1 (0,0)]
action = do modifyMark (\Nothing -> Just MarkX) (1,0)
mapM getMark [(0,0), (1,0)]
in [Just MarkX, Just MarkX] @=? evalGo action cursor
, "removes from an existing mark property" ~:
let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]]
action = do modifyMark (\(Just MarkX) -> Nothing) (1,0)
modifyMark (\(Just MarkX) -> Nothing) (0,1)
mapM getMark [(0,0), (1,0), (0,1)]
in [Just MarkX, Nothing, Nothing] @=? evalGo action cursor
, "removes and adds at the same time" ~:
let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]]
action = do modifyMark (\(Just MarkX) -> Just MarkSquare) (0,0)
modifyMark (\(Just MarkX) -> Nothing) (0,1)
mapM getMark [(0,0), (1,0), (0,1)]
in [Just MarkSquare, Just MarkX, Nothing] @=? evalGo action cursor
]
addChildTests = "addChild" ~: TestList
[ "adds a first child" ~: do
cursorNode (execGo (addChild emptyNode) $ rootCursor emptyNode) @?= node1 [] emptyNode
cursorNode (execGo (addChild $ node1 [W $ Just (1,1)] $ node [B $ Just (2,2)]) $ rootCursor $
node [B $ Just (0,0)]) @?=
node1 [B $ Just (0,0)] (node1 [W $ Just (1,1)] $ node [B $ Just (2,2)])
, "adds a child to the end of the parent's child list" ~:
cursorNode (execGo (addChild $ node [MN 4]) $ rootCursor $
node' [B Nothing] [node [MN 2], node [MN 3]]) @?=
node' [B Nothing] [node [MN 2], node [MN 3], node [MN 4]]
, "fires childAddedEvent after adding a child" ~:
let cursor = rootCursor $ node' [B Nothing] [node [MN 2], node [MN 3]]
action = do on childAddedEvent $ \index -> do
cursor <- getCursor
tell [(index, cursorNode cursor)]
addChild $ node [MN 4]
in execWriter (runGoT action cursor) @?=
[(2, node' [B Nothing] [node [MN 2], node [MN 3], node [MN 4]])]
]
addChildAtTests = "addChildAt" ~: TestList
[ "adds an only child" ~:
cursorNode (execGo (addChildAt 0 $ node [B Nothing]) (rootCursor $ node [])) @?=
node' [] [node [B Nothing]]
, "adds a first child" ~:
cursorNode (execGo (addChildAt 0 $ node [B $ Just (0,0)])
(rootCursor $ node' [] [node [B $ Just (1,1)]])) @?=
node' [] [node [B $ Just (0,0)],
node [B $ Just (1,1)]]
, "adds a middle child" ~:
cursorNode (execGo (addChildAt 1 $ node [B $ Just (1,1)])
(rootCursor $ node' [] [node [B $ Just (0,0)],
node [B $ Just (2,2)]])) @?=
node' [] [node [B $ Just (0,0)],
node [B $ Just (1,1)],
node [B $ Just (2,2)]]
, "adds a last child" ~:
cursorNode (execGo (addChildAt 2 $ node [B $ Just (2,2)])
(rootCursor $ node' [] [node [B $ Just (0,0)],
node [B $ Just (1,1)]])) @?=
node' [] [node [B $ Just (0,0)],
node [B $ Just (1,1)],
node [B $ Just (2,2)]]
, "fires childAddedEvent after adding a child" ~:
let cursor = rootCursor $ node' [B Nothing] [node [MN 2], node [MN 4]]
action = do on childAddedEvent $ \index -> do
cursor <- getCursor
tell [(index, cursorNode cursor)]
addChildAt 1 $ node [MN 3]
in execWriter (runGoT action cursor) @?=
[(1, node' [B Nothing] [node [MN 2], node [MN 3], node [MN 4]])]
, "path stack correctness" ~: TestList
[ "basic case just not needing updating" ~:
let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]]
action = do pushPosition
True <- goUp
addChildAt 1 $ node [W $ Just (0,0)]
popPosition
in cursorNode (execGo action cursor) @?= node [W Nothing]
, "basic case just needing updating" ~:
let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]]
action = do pushPosition
True <- goUp
addChildAt 0 $ node [W $ Just (0,0)]
popPosition
in cursorNode (execGo action cursor) @?= 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
pushPosition
True <- goUp
addChildAt 0 $ node [W Nothing]
popPosition
in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)]
, "multiple paths to update" ~:
let at y x = B $ Just (y,x)
level0Node = node' [at 0 0] $ map level1Node [0..1]
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]
pushPosition
replicateM_ 3 goUp
pushPosition
True <- and <$> sequence [goDown 1, goDown 2, goDown 2, goUp, goDown 1]
addChildAt 0 $ node1 [] $ node []
True <- and <$> sequence [goDown 0, goDown 0]
goToRoot
popPosition
popPosition
in cursorNode (execGo action $ rootCursor level0Node) @?= 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
addChildAt 0 $ node [B $ Just (2,2)]
on navigationEvent $ \step -> tell [step]
popPosition
log = execWriter (runGoT action cursor)
in log @?= [GoDown 1, GoUp 1]
]
]
deleteChildAtTests = "deleteChildAt" ~: TestList
[ "ignores invalid indices" ~: do
second cursorNode (runGo (deleteChildAt 0) $ rootCursor $ node []) @?=
(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)
, "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])
, "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])
, "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 })
, "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 })
, "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)]
, "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
pushPosition
True <- goUp
NodeDeleteOk <- deleteChildAt 1
popPosition
in cursorNode (execGo action cursor) @?= 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
pushPosition
True <- goUp
NodeDeleteOk <- deleteChildAt 0
popPosition
in cursorNode (execGo action cursor) @?= 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
pushPosition
True <- goUp
NodeDeleteOk <- deleteChildAt 0
popPosition
in cursorNode (execGo action cursor) @?= node [W $ Just (2,2)]
, "multiple paths to update" ~:
let at y x = B $ Just (y,x)
level0Node = node' [at 0 0] $ map level1Node [0..1]
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]
pushPosition
True <- goUp
NodeDeleteOk <- deleteChildAt 1
pushPosition
goToRoot
True <- goDown 0
True <- goDown 2
pushPosition
True <- goUp
NodeDeleteOk <- deleteChildAt 0
goToRoot
True <- goDown 1
True <- goDown 2
NodeDeleteOk <- deleteChildAt 1
replicateM_ 3 popPosition
in cursorNode (execGo action $ rootCursor level0Node) @?= 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
pushPosition
True <- goUp
pushPosition
True <- goDown 0
pushPosition
True <- goUp
deleteChildAt 1
in second cursorNode (runGo action $ rootCursor base) @?=
(NodeDeleteOnPathStack, base)
]
]
gameInfoChangedTests = "gameInfoChangedEvent" ~: TestList
[ "fires when navigating down" ~:
let cursor = rootCursor $
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")]
, "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)]
, "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
on gameInfoChangedEvent onInfo
popPosition
in execWriter (runGoT action cursor) @?=
[(Nothing, Just $ toSimpleText "Foo"), (Just $ toSimpleText "Foo", Nothing)]
, "fires when modifying properties" ~:
let cursor = rootCursor $ node []
action = do on gameInfoChangedEvent onInfo
modifyProperties $ const [GN $ toSimpleText "Foo"]
modifyProperties $ const [GN $ toSimpleText "Bar"]
modifyProperties $ const []
in execWriter (runGoT action cursor) @?=
[(Nothing, Just $ toSimpleText "Foo"),
(Just $ toSimpleText "Foo", Just $ toSimpleText "Bar"),
(Just $ toSimpleText "Bar", Nothing)]
]
where onInfo old new = tell [(gameInfoGameName old, gameInfoGameName new)]