werewolf 0.4.3.2 → 0.4.4.0

raw patch · 14 files changed

+727/−767 lines, 14 filesdep ~MonadRandomdep ~QuickCheckdep ~aeson

Dependency ranges changed: MonadRandom, QuickCheck, aeson, containers, directory, extra, filepath, lens, mtl, optparse-applicative, tasty-quickcheck, text, transformers

Files

• CHANGELOG.md +10/−23
• app/Werewolf/Commands/Help.hs +1/−1
• app/Werewolf/Commands/Start.hs +2/−1
• src/Game/Werewolf/Command.hs +4/−4
• src/Game/Werewolf/Engine.hs +25/−23
• src/Game/Werewolf/Game.hs +5/−5
• src/Game/Werewolf/Player.hs +3/−3
• src/Game/Werewolf/Response.hs +19/−44
• src/Game/Werewolf/Role.hs +2/−2
• test/app/Main.hs +8/−1
• test/src/Game/Werewolf/Test/Arbitrary.hs +170/−77
• test/src/Game/Werewolf/Test/Command.hs +309/−351
• test/src/Game/Werewolf/Test/Engine.hs +142/−205
• werewolf.cabal +27/−27

@@ -2,12 +2,19 @@  #### Upcoming -#### v0.4.3.2+#### v0.4.4.0 +*Minor*++* Removed `playerHealedMessage` and replaced with the generic `noPlayerDevouredMessage`. ([#80](https://github.com/hjwylde/werewolf/issues/80))+* Removed `playerProtectedMessage` and replaced with the generic `noPlayerDevouredMessage`. ([#80](https://github.com/hjwylde/werewolf/issues/80))+ *Revisions* -* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83))-* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82))+* Privatised underscore methods and changed old uses to using lens. ([#20](https://github.com/hjwylde/werewolf/issues/20))+* Tidied up arbitrary instances by using `newtype`'s. ([#78](https://github.com/hjwylde/werewolf/issues/78))+* Fixed the `noPlayerDevouredMessage` to be displayed after sunrise. ([#80](https://github.com/hjwylde/werewolf/issues/80))+* Removed `Show` instance for `Command` and used `Blind`. ([#78](https://github.com/hjwylde/werewolf/issues/78))  #### v0.4.3.1 @@ -21,13 +28,6 @@  * Added the Defender role. ([#38](https://github.com/hjwylde/werewolf/issues/38)) -#### v0.4.2.3--*Revisions*--* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83))-* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82))- #### v0.4.2.2  *Revisions*@@ -46,13 +46,6 @@  * Added the Villager-Villager role. ([#37](https://github.com/hjwylde/werewolf/issues/37)) -#### v0.4.1.3--*Revisions*--* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83))-* Fixed the `heal` command help message to not require a `PLAYER` argument. ([#82](https://github.com/hjwylde/werewolf/issues/82))- #### v0.4.1.2  *Revisions*@@ -70,12 +63,6 @@ *Minor*  * Added the Witch role. ([#5](https://github.com/hjwylde/werewolf/issues/5))--#### v0.4.0.1--*Revisions*--* Fixed grammar for the `currentStageMessages`. ([#83](https://github.com/hjwylde/werewolf/issues/83))  #### v0.4.0.0 

@@ -62,7 +62,7 @@ commandsMessages :: [Text] commandsMessages =     [ "end - ends the current game."-    , "heal - heal a devoured player."+    , "heal PLAYER - heal a devoured player."     , "pass - pass on healing or poisoning a player."     , "ping - pings the status of the current game publicly."     , "poison PLAYER - poison a player."

@@ -17,6 +17,7 @@     handle, ) where +import Control.Lens import Control.Monad.Except import Control.Monad.Extra import Control.Monad.State@@ -60,4 +61,4 @@   findByName :: Text -> Maybe Role-findByName name = find ((name ==) . T.toLower . _name) allRoles+findByName name' = find ((name' ==) . T.toLower . view name) allRoles

@@ -53,7 +53,7 @@      votes %= Map.insert callerName targetName -    aliveWerewolfNames <- uses players $ map _name . filterAlive . filterWerewolves+    aliveWerewolfNames <- uses players $ map (view name) . filterAlive . filterWerewolves      tell $ map (\werewolfName -> playerMadeDevourVoteMessage werewolfName callerName targetName) (aliveWerewolfNames \\ [callerName]) @@ -107,12 +107,12 @@         pendingVoters <- getPendingVoters          tell [waitingOnMessage Nothing pendingVoters]-        tell $ map (pingPlayerMessage . _name) pendingVoters+        tell $ map (pingPlayerMessage . view name) pendingVoters     WerewolvesTurn  -> do         pendingVoters <- getPendingVoters          tell [pingWerewolvesMessage]-        tell $ map (pingPlayerMessage . _name) (filterWerewolves pendingVoters)+        tell $ map (pingPlayerMessage . view name) (filterWerewolves pendingVoters)     WitchsTurn      -> do         witch <- uses players $ head . filterWitches @@ -208,7 +208,7 @@     where         standardStatusMessages stage players =             currentStageMessages callerName stage ++ [-            rolesInGameMessage (Just callerName) $ map _role players,+            rolesInGameMessage (Just callerName) $ map (view role) players,             playersInGameMessage callerName players             ] 

@@ -67,7 +67,7 @@ import           Game.Werewolf.Player   hiding (doesPlayerExist) import qualified Game.Werewolf.Player   as Player import           Game.Werewolf.Response-import           Game.Werewolf.Role     hiding (name, _name)+import           Game.Werewolf.Role     hiding (name) import qualified Game.Werewolf.Role     as Role  import System.Directory@@ -125,9 +125,9 @@             getVoteResult >>= \votees -> case votees of                 [target]    ->                     ifM (uses protect $ maybe False (== target ^. name))-                        (events %= cons (ProtectEvent $ target ^. name))+                        (events %= cons NoDevourEvent)                         (events %= cons (DevourEvent $ target ^. name))-                _           -> tell [noPlayerDevouredMessage]+                _           -> events %= cons NoDevourEvent              protect .= Nothing @@ -138,6 +138,12 @@             events %= (++ [PoisonEvent targetName])             poison .= Nothing +        whenM (use heal) $ do+            devourEvent <- uses events $ \events -> head [event | event@(DevourEvent _) <- events]++            events  %= cons NoDevourEvent . delete devourEvent+            heal    .= False+         witch <- uses players (head . filterWitches)          whenM (use healUsed &&^ use poisonUsed) advanceStage@@ -149,7 +155,7 @@     stage'          <- use stage     alivePlayers    <- uses players filterAlive -    let nextStage = if length (nub $ map (_allegiance . _role) alivePlayers) <= 1+    let nextStage = if length (nub $ map (view $ role . allegiance) alivePlayers) <= 1         then GameOver         else head $ filter (stageAvailable game) (drop1 $ dropWhile (stage' /=) stageCycle) @@ -169,33 +175,28 @@     mapM_ applyEvent available  eventAvailable :: MonadState Game m => Event -> m Bool-eventAvailable (DevourEvent _) = gets isSunrise-eventAvailable (PoisonEvent _) = gets isSunrise-eventAvailable (ProtectEvent _) = gets isSunrise+eventAvailable (DevourEvent _)  = gets isSunrise+eventAvailable NoDevourEvent    = gets isSunrise+eventAvailable (PoisonEvent _)  = gets isSunrise  applyEvent :: (MonadState Game m, MonadWriter [Message] m) => Event -> m () applyEvent (DevourEvent targetName) = do-    player  <- uses players $ findByName_ targetName-    heal'   <- use heal+    player <- uses players $ findByName_ targetName -    if heal'-        then tell [playerHealedMessage $ player ^. name]-        else do-            killPlayer player-            tell [playerDevouredMessage player]+    killPlayer player -    heal .= False-applyEvent (PoisonEvent name) = do+    tell [playerDevouredMessage player]+applyEvent NoDevourEvent            = tell [noPlayerDevouredMessage]+applyEvent (PoisonEvent name)       = do     player <- uses players $ findByName_ name      killPlayer player      tell [playerPoisonedMessage player]-applyEvent (ProtectEvent name) = tell [playerProtectedMessage name]  checkGameOver :: (MonadState Game m, MonadWriter [Message] m) => m () checkGameOver = do-    aliveAllegiances <- uses players $ nub . map (_allegiance . _role) . filterAlive+    aliveAllegiances <- uses players $ nub . map (view $ role . allegiance) . filterAlive      when (length aliveAllegiances <= 1) $ stage .= GameOver >> get >>= tell . gameOverMessages @@ -204,8 +205,9 @@     when (playerNames /= nub playerNames)   $ throwError [privateMessage callerName "Player names must be unique."]     when (length players < 7)               $ throwError [privateMessage callerName "Must have at least 7 players."]     when (length players > 24)              $ throwError [privateMessage callerName "Cannot have more than 24 players."]-    forM_ restrictedRoles $ \role ->-        when (length (filter ((role ==) . _role) players) > 1) $ throwError [privateMessage callerName $ T.concat ["Cannot have more than 1 ", role ^. Role.name, "."]]+    forM_ restrictedRoles $ \role' ->+        when (length (filter ((role' ==) . view role) players) > 1) $+            throwError [privateMessage callerName $ T.concat ["Cannot have more than 1 ", role' ^. Role.name, "."]]      let game = newGame players @@ -213,7 +215,7 @@      return game     where-        playerNames = map _name players+        playerNames = map (view name) players         restrictedRoles = [defenderRole, scapegoatRole, seerRole, villagerVillagerRole, witchRole]  killPlayer :: MonadState Game m => Player -> m ()@@ -297,8 +299,8 @@ randomiseRoles :: MonadIO m => [Role] -> Int -> m [Role] randomiseRoles extraRoles n = liftIO . evalRandIO . shuffleM $ extraRoles ++ werewolfRoles ++ villagerRoles     where-        extraWerewolfRoles = filter ((==) Role.Werewolves . _allegiance) extraRoles-        extraVillagerRoles = filter ((==) Role.Villagers . _allegiance) extraRoles+        extraWerewolfRoles = filter ((==) Role.Werewolves . view allegiance) extraRoles+        extraVillagerRoles = filter ((==) Role.Villagers . view allegiance) extraRoles          werewolfRoles = replicate (n `quot` 6 + 1 - length extraWerewolfRoles) werewolfRole         villagerRoles = replicate (n - length (extraVillagerRoles ++ werewolfRoles)) villagerRole

@@ -13,7 +13,7 @@  module Game.Werewolf.Game (     -- * Game-    Game(..), stage, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect,+    Game, stage, players, events, passes, heal, healUsed, poison, poisonUsed, priorProtect,     protect, see, votes,     newGame, @@ -64,7 +64,7 @@             | WerewolvesTurn | WitchsTurn     deriving (Eq, Read, Show) -data Event = DevourEvent Text | PoisonEvent Text | ProtectEvent Text+data Event = DevourEvent Text | NoDevourEvent | PoisonEvent Text     deriving (Eq, Read, Show)  makeLenses ''Game@@ -72,7 +72,7 @@ makeLenses ''Stage  newGame :: [Player] -> Game-newGame players = game { _stage = head $ filter (stageAvailable game) stageCycle }+newGame players = game & stage .~ head (filter (stageAvailable game) stageCycle)     where         game = Game             { _stage        = Sunset@@ -126,7 +126,7 @@ getPlayerVote playerName game = game ^. votes . at playerName  getPendingVoters :: Game -> [Player]-getPendingVoters game = filter (flip Map.notMember votes' . _name) alivePlayers+getPendingVoters game = filter (flip Map.notMember votes' . view name) alivePlayers     where         votes'          = game ^. votes         alivePlayers    = filterAlive $ game ^. players@@ -151,7 +151,7 @@ stageAvailable _ VillagesTurn       = True stageAvailable game WerewolvesTurn  = any isWerewolf (filterAlive $ game ^. players) stageAvailable game WitchsTurn      =-    (any isWitch (filterAlive $ game ^. players))+    any isWitch (filterAlive $ game ^. players)     && (not (game ^. healUsed) || not (game ^. poisonUsed))  getDevourEvent :: Game -> Maybe Event

@@ -13,7 +13,7 @@  module Game.Werewolf.Player (     -- * Player-    Player(..), name, role, state,+    Player, name, role, state,     newPlayer,      -- ** Searches@@ -40,7 +40,7 @@ import Data.Maybe import Data.Text  (Text) -import Game.Werewolf.Role hiding (name, _name)+import Game.Werewolf.Role hiding (name)  data Player = Player     { _name  :: Text@@ -57,7 +57,7 @@ newPlayer name role = Player name role Alive  findByName :: Text -> [Player] -> Maybe Player-findByName name = find ((name ==) . _name)+findByName name' = find ((name' ==) . view name)  findByName_ :: Text -> [Player] -> Player findByName_ name = fromJust . findByName name

@@ -40,9 +40,6 @@     -- ** Status messages     currentStageMessages, rolesInGameMessage, playersInGameMessage, waitingOnMessage, -    -- ** Defender's turn messages-    playerProtectedMessage,-     -- ** Seer's turn messages     playerSeenMessage, @@ -54,7 +51,7 @@     playerMadeDevourVoteMessage, playerDevouredMessage, noPlayerDevouredMessage,      -- ** Witch's turn messages-    playerHealedMessage, playerPoisonedMessage,+    playerPoisonedMessage,      -- ** Generic error messages     gameIsOverMessage, playerDoesNotExistMessage, playerCannotDoThatMessage,@@ -89,7 +86,7 @@  import           Game.Werewolf.Game import           Game.Werewolf.Player-import           Game.Werewolf.Role   (Allegiance (..), Role, allegiance, description, _allegiance)+import           Game.Werewolf.Role   (Allegiance (..), Role, allegiance, description) import qualified Game.Werewolf.Role   as Role import           GHC.Generics @@ -148,7 +145,7 @@ newGameMessages :: Game -> [Message] newGameMessages game = [     newPlayersInGameMessage players',-    rolesInGameMessage Nothing $ map _role players'+    rolesInGameMessage Nothing $ map (view role) players'     ] ++ map (newPlayerMessage players') players'     ++ villagerVillagerMessages     ++ stageMessages game@@ -162,7 +159,7 @@ newPlayersInGameMessage :: [Player] -> Message newPlayersInGameMessage players = publicMessage $ T.concat [     "A new game of werewolf is starting with ",-    T.intercalate ", " (map _name players), "!"+    T.intercalate ", " (map (view name) players), "!"     ]  newPlayerMessage :: [Player] -> Player -> Message@@ -173,7 +170,7 @@     where         packMessage             | length (filterWerewolves players) <= 1    = "."-            | otherwise                                 = T.concat [", along with ", T.intercalate ", " (map _name $ filterWerewolves players \\ [player]), "."]+            | otherwise                                 = T.concat [", along with ", T.intercalate ", " (map (view name) $ filterWerewolves players \\ [player]), "."]  villagerVillagerMessage :: Text -> Message villagerVillagerMessage name = publicMessage $ T.unwords [@@ -186,12 +183,12 @@ stageMessages :: Game -> [Message] stageMessages game = case game ^. stage of     GameOver        -> []-    DefendersTurn   -> defendersTurnMessages (_name . head . filterDefenders $ game ^. players)-    SeersTurn       -> seersTurnMessages (_name . head . filterSeers $ game ^. players)+    DefendersTurn   -> defendersTurnMessages (view name . head . filterDefenders $ game ^. players)+    SeersTurn       -> seersTurnMessages (view name . head . filterSeers $ game ^. players)     Sunrise         -> [sunriseMessage]     Sunset          -> [nightFallsMessage]     VillagesTurn    -> villagesTurnMessages-    WerewolvesTurn  -> werewolvesTurnMessages (map _name . filterAlive . filterWerewolves $ game ^. players)+    WerewolvesTurn  -> werewolvesTurnMessages (map (view name) . filterAlive . filterWerewolves $ game ^. players)     WitchsTurn      -> witchsTurnMessages game  defendersTurnMessages :: Text -> [Message]@@ -245,15 +242,15 @@  gameOverMessages :: Game -> [Message] gameOverMessages game = case aliveAllegiances of-    [allegiance]    -> concat [-        [publicMessage $ T.unwords ["The game is over! The", T.pack $ show allegiance, "have won."]],-        map (playerWonMessage . _name) (filter ((allegiance ==) . _allegiance . _role) players'),-        map (playerLostMessage . _name) (filter ((allegiance /=) . _allegiance . _role) players')+    [allegiance']    -> concat [+        [publicMessage $ T.unwords ["The game is over! The", T.pack $ show allegiance', "have won."]],+        map (playerWonMessage . view name) (filter ((allegiance' ==) . view (role . allegiance)) players'),+        map (playerLostMessage . view name) (filter ((allegiance' /=) . view (role . allegiance)) players')         ]-    _               -> publicMessage "The game is over! Everyone died...":map (playerLostMessage . _name) players'+    _               -> publicMessage "The game is over! Everyone died...":map (playerLostMessage . view name) players'     where         players'            = game ^. players-        aliveAllegiances    = nub $ map (_allegiance . _role) (filterAlive players')+        aliveAllegiances    = nub $ map (view $ role . allegiance) (filterAlive players')  playerWonMessage :: Text -> Message playerWonMessage to = privateMessage to "Victory! You won!"@@ -283,19 +280,10 @@ currentStageMessages to GameOver    = [gameIsOverMessage to] currentStageMessages _ Sunrise      = [] currentStageMessages _ Sunset       = []+    -- TODO (hjw): pluralise this correctly for the Seer currentStageMessages to turn        = [privateMessage to $ T.concat [-    "It's currently the ", showTurn turn, " turn."+    "It's currently the ", T.pack $ show turn, "' turn."     ]]-    where-        showTurn :: Stage -> Text-        showTurn DefendersTurn  = "Defender's"-        showTurn GameOver       = undefined-        showTurn SeersTurn      = "Seer's"-        showTurn Sunrise        = undefined-        showTurn Sunset         = undefined-        showTurn VillagesTurn   = "Village's"-        showTurn WerewolvesTurn = "Werewolves'"-        showTurn WitchsTurn     = "Witch's"  rolesInGameMessage :: Maybe Text -> [Role] -> Message rolesInGameMessage mTo roles = Message mTo $ T.concat [@@ -306,7 +294,7 @@     "."     ]     where-        roleCounts = map (\list -> (head list, length list)) (groupSortOn Role._name roles)+        roleCounts = map (\list -> (head list, length list)) (groupSortOn (view Role.name) roles)  playersInGameMessage :: Text -> [Player] -> Message playersInGameMessage to players = privateMessage to . T.intercalate "\n" $ [@@ -315,7 +303,7 @@     where         alivePlayersText = T.concat [             "The following players are still alive: ",-            T.intercalate ", " (map _name $ filterAlive players), "."+            T.intercalate ", " (map (view name) $ filterAlive players), "."             ]         deadPlayersText = T.concat [             "The following players are dead: ",@@ -327,13 +315,7 @@     "Waiting on ", T.intercalate ", " playerNames, "..."     ]     where-        playerNames = map _name players--playerProtectedMessage :: Text -> Message-playerProtectedMessage name = publicMessage $ T.unwords-    [ "As you emerge from your home you see", name, "outside waving a wolf paw around."-    , "Some poor Werewolf must have tried to attack them while the Defender was on watch."-    ]+        playerNames = map (view name) players  playerSeenMessage :: Text -> Player -> Message playerSeenMessage to target = privateMessage to $ T.concat [@@ -388,13 +370,6 @@ noPlayerDevouredMessage = publicMessage $ T.unwords [     "Surprisingly you see everyone present at the town square.",     "Perhaps the Werewolves have left Miller's Hollow?"-    ]--playerHealedMessage :: Text -> Message-playerHealedMessage name = publicMessage $ T.unwords [-    "As you open them you notice a door broken down and blood over the cobblestones.",-    name, "hobbles over, clutching the bandages round their stomach.",-    "The Witch must have seen their body and healed them..."     ]  playerPoisonedMessage :: Player -> Message

@@ -14,7 +14,7 @@  module Game.Werewolf.Role (     -- * Role-    Role(..), name, allegiance, description, advice,+    Role, name, allegiance, description, advice,      -- ** Instances     allRoles, defenderRole, scapegoatRole, seerRole, villagerRole, villagerVillagerRole,@@ -47,7 +47,7 @@     , _allegiance   = Villagers     , _description  = T.unwords         [ "A knight living in Miller's Hollow."-        , "The Defender has the ability to protect one player each night."+        , "The Defender has the ability to protect one player, except themself, each night."         ]     , _advice       =         "Be careful when you choose to protect someone, you cannot protect them 2 nights in a row."

@@ -75,6 +75,8 @@     , testProperty "poison command errors when not witch's turn"        prop_poisonCommandErrorsWhenNotWitchsTurn     , testProperty "poison command errors when caller has poisoned"     prop_poisonCommandErrorsWhenCallerHasPoisoned     , testProperty "poison command errors when caller not witch"        prop_poisonCommandErrorsWhenCallerNotWitch+    -- TODO (hjw)+    --, testProperty "poison command errors when caller devoured and not healed"   prop_poisonCommandErrorsWhenCallerDevouredAndNotHealed     , testProperty "poison command sets poison"                         prop_poisonCommandSetsPoison     , testProperty "poison command sets poison used"                    prop_poisonCommandSetsPoisonUsed @@ -121,8 +123,12 @@     , testProperty "check stage does nothing when game over"            prop_checkStageDoesNothingWhenGameOver      , testProperty "check defender's turn advances to werewolves' turn" prop_checkDefendersTurnAdvancesToWerewolvesTurn+    -- TODO (hjw)+    --, testProperty "check defender's turn advances when no defender"    prop_checkDefendersTurnAdvancesWhenNoDefender      , testProperty "check seer's turn advances to defender's turn"  prop_checkSeersTurnAdvancesToDefendersTurn+    -- TODO (hjw)+    --, testProperty "check seer's turn advances when no seer"        prop_checkSeersTurnAdvancesWhenNoSeer     , testProperty "check seer's turn resets sees"                  prop_checkSeersTurnResetsSee     , testProperty "check seer's turn does nothing unless seen"     prop_checkSeersTurnDoesNothingUnlessSeen @@ -134,7 +140,6 @@     , testProperty "check villages' turn does nothing unless all voted"                     prop_checkVillagesTurnDoesNothingUnlessAllVoted      , testProperty "check werewolves' turn advances to witch's turn"                    prop_checkWerewolvesTurnAdvancesToWitchsTurn-    , testProperty "check werewolves' turn doesn't skip witch's turn when witch devoured" prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured     , testProperty "check werewolves' turn skips witch's turn when healed and poisoned" prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned     , testProperty "check werewolves' turn kills one player when consensus"             prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus     , testProperty "check werewolves' turn kills no one when conflicted"                prop_checkWerewolvesTurnKillsNoOneWhenConflicted@@ -144,6 +149,8 @@     , testProperty "check werewolves' turn does nothing unless all voted"               prop_checkWerewolvesTurnDoesNothingUnlessAllVoted      , testProperty "check witch's turn advances to villages' turn"      prop_checkWitchsTurnAdvancesToVillagesTurn+    -- TODO (hjw)+    --, testProperty "check witch's turn advances when no witch"          prop_checkWitchsTurnAdvancesWhenNoWitch     , testProperty "check witch's turn heals devouree when healed"      prop_checkWitchsTurnHealsDevoureeWhenHealed     , testProperty "check witch's turn kills one player when poisoned"  prop_checkWitchsTurnKillsOnePlayerWhenPoisoned     , testProperty "check witch's turn does nothing when passed"        prop_checkWitchsTurnDoesNothingWhenPassed

@@ -12,8 +12,10 @@     -- * Initial arbitraries      -- ** Game-    arbitraryNewGame, arbitraryGameWithDevourVotes, arbitraryGameWithDevourEventForVillager,-    arbitraryGameWithProtect, arbitraryGameWithProtectAndDevourVotes,+    GameAtDefendersTurn(..), GameAtGameOver(..), GameAtVillagesTurn(..), GameAtWerewolvesTurn(..),+    GameAtWitchsTurn(..), GameAtSeersTurn(..),+    GameWithDevourEvent(..), GameWithDevourVotes(..), GameWithHeal(..), GameWithLynchVotes(..),+    GameWithPoison(..), GameWithProtect(..), GameWithProtectAndDevourVotes(..), GameWithSee(..),      -- ** Player     arbitraryPlayerSet,@@ -26,7 +28,7 @@     arbitrarySeeCommand, runArbitraryCommands,      -- ** Player-    arbitraryPlayer, arbitraryDefender, arbitrarySeer, arbitraryWerewolf, arbitraryWitch,+    arbitraryPlayer, arbitraryWerewolf, ) where  import Control.Lens hiding (elements)@@ -40,20 +42,17 @@ import Game.Werewolf.Engine    (checkStage) import Game.Werewolf.Game import Game.Werewolf.Player-import Game.Werewolf.Role      hiding (name, _name)+import Game.Werewolf.Role      hiding (name) import Game.Werewolf.Test.Util  import Test.QuickCheck -instance Show Command where-    show _ = "command"- instance Arbitrary Game where     arbitrary = do-        game    <- arbitraryNewGame-        stage   <- arbitrary+        game    <- newGame <$> arbitraryPlayerSet+        stage'  <- arbitrary -        return $ game { _stage = stage }+        return $ game & stage .~ stage'  instance Arbitrary Stage where     arbitrary = elements@@ -71,37 +70,145 @@ instance Arbitrary Text where     arbitrary = T.pack <$> vectorOf 6 (elements ['a'..'z']) -arbitraryNewGame :: Gen Game-arbitraryNewGame = newGame <$> arbitraryPlayerSet+newtype GameAtDefendersTurn = GameAtDefendersTurn Game+    deriving (Eq, Show) -arbitraryGameWithDevourVotes :: Gen Game-arbitraryGameWithDevourVotes = arbitrary >>= runArbitraryDevourVoteCommands+instance Arbitrary GameAtDefendersTurn where+    arbitrary = do+        game <- arbitrary -arbitraryGameWithDevourEvent :: Gen Game-arbitraryGameWithDevourEvent = do-    game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) == 1+        return $ GameAtDefendersTurn (game & stage .~ DefendersTurn) -    return $ run_ checkStage game+newtype GameAtGameOver = GameAtGameOver Game+    deriving (Eq, Show) -arbitraryGameWithDevourEventForVillager :: Gen Game-arbitraryGameWithDevourEventForVillager =-    suchThat arbitraryGameWithDevourEvent $ \game -> all isVillager (filterDead $ game ^. players)+instance Arbitrary GameAtGameOver where+    arbitrary = do+        game <- arbitrary -arbitraryGameWithProtect :: Gen Game-arbitraryGameWithProtect = do-    game        <- arbitrary-    let game'   = game { _stage = DefendersTurn }-    command     <- arbitraryProtectCommand game'+        return $ GameAtGameOver (game & stage .~ GameOver) -    return $ run_ (apply command) game'+newtype GameAtVillagesTurn = GameAtVillagesTurn Game+    deriving (Eq, Show) -arbitraryGameWithProtectAndDevourVotes :: Gen Game-arbitraryGameWithProtectAndDevourVotes = arbitraryGameWithProtect >>= runArbitraryDevourVoteCommands+instance Arbitrary GameAtVillagesTurn where+    arbitrary = do+        game <- arbitrary +        return $ GameAtVillagesTurn (game & stage .~ VillagesTurn)++newtype GameAtWerewolvesTurn = GameAtWerewolvesTurn Game+    deriving (Eq, Show)++instance Arbitrary GameAtWerewolvesTurn where+    arbitrary = do+        game <- arbitrary++        return $ GameAtWerewolvesTurn (game & stage .~ WerewolvesTurn)++newtype GameAtWitchsTurn = GameAtWitchsTurn Game+    deriving (Eq, Show)++instance Arbitrary GameAtWitchsTurn where+    arbitrary = do+        game <- arbitrary++        return $ GameAtWitchsTurn (game & stage .~ WitchsTurn)++newtype GameAtSeersTurn = GameAtSeersTurn Game+    deriving (Eq, Show)++instance Arbitrary GameAtSeersTurn where+    arbitrary = do+        game <- arbitrary++        return $ GameAtSeersTurn (game & stage .~ SeersTurn)++newtype GameWithDevourEvent = GameWithDevourEvent Game+    deriving (Eq, Show)++instance Arbitrary GameWithDevourEvent where+    arbitrary = do+        (GameWithDevourVotes game) <- suchThat arbitrary $ \(GameWithDevourVotes game) ->+            length (getVoteResult game) == 1++        return $ GameWithDevourEvent (run_ checkStage game)++newtype GameWithDevourVotes = GameWithDevourVotes Game+    deriving (Eq, Show)++instance Arbitrary GameWithDevourVotes where+    arbitrary = do+        game <- arbitrary++        GameWithDevourVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ WerewolvesTurn)++newtype GameWithHeal = GameWithHeal Game+    deriving (Eq, Show)++instance Arbitrary GameWithHeal where+    arbitrary = do+        (GameWithDevourEvent game)  <- arbitrary+        (Blind command)             <- arbitraryHealCommand game++        return $ GameWithHeal (run_ (apply command) game)++newtype GameWithLynchVotes = GameWithLynchVotes Game+    deriving (Eq, Show)++instance Arbitrary GameWithLynchVotes where+    arbitrary = do+        game <- arbitrary++        GameWithLynchVotes <$> runArbitraryCommands (length $ game ^. players) (game & stage .~ VillagesTurn)++newtype GameWithPoison = GameWithPoison Game+    deriving (Eq, Show)++instance Arbitrary GameWithPoison where+    arbitrary = do+        game            <- arbitrary+        let game'       = game & stage .~ WitchsTurn+        (Blind command) <- arbitraryPoisonCommand game'++        return $ GameWithPoison (run_ (apply command) game')++newtype GameWithProtect = GameWithProtect Game+    deriving (Eq, Show)++instance Arbitrary GameWithProtect where+    arbitrary = do+        game            <- arbitrary+        let game'       = game & stage .~ DefendersTurn+        (Blind command) <- arbitraryProtectCommand game'++        return $ GameWithProtect (run_ (apply command) game')++newtype GameWithProtectAndDevourVotes = GameWithProtectAndDevourVotes Game+    deriving (Eq, Show)++instance Arbitrary GameWithProtectAndDevourVotes where+    arbitrary = do+        (GameWithProtect game)  <- arbitrary+        let game'               = run_ checkStage game++        GameWithProtectAndDevourVotes <$> runArbitraryCommands (length $ game' ^. players) game'++newtype GameWithSee = GameWithSee Game+    deriving (Eq, Show)++instance Arbitrary GameWithSee where+    arbitrary = do+        game            <- arbitrary+        let game'       = game & stage .~ SeersTurn+        (Blind command) <- arbitrarySeeCommand game'++        return $ GameWithSee (run_ (apply command) game')+ arbitraryPlayerSet :: Gen [Player] arbitraryPlayerSet = do     n <- choose (10, 24)-    players <- nubOn _name <$> infiniteList+    players <- nubOn (view name) <$> infiniteList      let defender            = head $ filterDefenders players     let scapegoat           = head $ filterScapegoats players@@ -114,12 +221,12 @@      return $ defender:scapegoat:seer:villagerVillager:witch:werewolves ++ villagers -arbitraryCommand :: Game -> Gen Command+arbitraryCommand :: Game -> Gen (Blind Command) arbitraryCommand game = case game ^. stage of-    GameOver        -> return noopCommand+    GameOver        -> return $ Blind noopCommand     DefendersTurn   -> arbitraryProtectCommand game-    Sunrise         -> return noopCommand-    Sunset          -> return noopCommand+    Sunrise         -> return $ Blind noopCommand+    Sunset          -> return $ Blind noopCommand     SeersTurn       -> arbitrarySeeCommand game     VillagesTurn    -> arbitraryLynchVoteCommand game     WerewolvesTurn  -> arbitraryDevourVoteCommand game@@ -129,103 +236,89 @@         arbitraryPoisonCommand game         ] -arbitraryDevourVoteCommand :: Game -> Gen Command+arbitraryDevourVoteCommand :: Game -> Gen (Blind Command) arbitraryDevourVoteCommand game = do     let applicableCallers   = filterWerewolves $ getPendingVoters game     target                  <- suchThat (arbitraryPlayer game) $ not . isWerewolf      if null applicableCallers-        then return noopCommand+        then return $ Blind noopCommand         else elements applicableCallers >>= \caller ->-            return $ devourVoteCommand (caller ^. name) (target ^. name)+            return . Blind $ devourVoteCommand (caller ^. name) (target ^. name) -arbitraryLynchVoteCommand :: Game -> Gen Command+arbitraryLynchVoteCommand :: Game -> Gen (Blind Command) arbitraryLynchVoteCommand game = do     let applicableCallers   = getPendingVoters game     target                  <- arbitraryPlayer game      if null applicableCallers-        then return noopCommand+        then return $ Blind noopCommand         else elements applicableCallers >>= \caller ->-            return $ lynchVoteCommand (caller ^. name) (target ^. name)+            return . Blind $ lynchVoteCommand (caller ^. name) (target ^. name) -arbitraryHealCommand :: Game -> Gen Command+arbitraryHealCommand :: Game -> Gen (Blind Command) arbitraryHealCommand game = do     let witch = head . filterWitches $ game ^. players      return $ if game ^. healUsed-        then noopCommand-        else seq (fromJust (getDevourEvent game)) $ healCommand (witch ^. name)+        then Blind noopCommand+        else seq (fromJust $ getDevourEvent game) (Blind $ healCommand (witch ^. name)) -arbitraryPassCommand :: Game -> Gen Command+arbitraryPassCommand :: Game -> Gen (Blind Command) arbitraryPassCommand game = do-    witch <- arbitraryWitch game+    let witch = head . filterWitches $ game ^. players -    return $ passCommand (witch ^. name)+    return . Blind $ passCommand (witch ^. name) -arbitraryPoisonCommand :: Game -> Gen Command+arbitraryPoisonCommand :: Game -> Gen (Blind Command) arbitraryPoisonCommand game = do     let witch   = head . filterWitches $ game ^. players     target      <- arbitraryPlayer game      return $ if isJust (game ^. poison)-        then noopCommand-        else poisonCommand (witch ^. name) (target ^. name)+        then Blind noopCommand+        else Blind $ poisonCommand (witch ^. name) (target ^. name) -arbitraryProtectCommand :: Game -> Gen Command+arbitraryProtectCommand :: Game -> Gen (Blind Command) arbitraryProtectCommand game = do     let defender    = head . filterDefenders $ game ^. players+    -- TODO (hjw): suchThat (/= priorProtect)     target          <- suchThat (arbitraryPlayer game) (defender /=)      return $ if isJust (game ^. protect)-        then noopCommand-        else protectCommand (defender ^. name) (target ^. name)+        then Blind noopCommand+        else Blind $ protectCommand (defender ^. name) (target ^. name) -arbitraryQuitCommand :: Game -> Gen Command+arbitraryQuitCommand :: Game -> Gen (Blind Command) arbitraryQuitCommand game = do     let applicableCallers = filterAlive $ game ^. players      if null applicableCallers-        then return noopCommand-        else elements applicableCallers >>= \caller -> return $ quitCommand (caller ^. name)+        then return $ Blind noopCommand+        else elements applicableCallers >>= \caller ->+            return . Blind $ quitCommand (caller ^. name) -arbitrarySeeCommand :: Game -> Gen Command+arbitrarySeeCommand :: Game -> Gen (Blind Command) arbitrarySeeCommand game = do     let seer    = head . filterSeers $ game ^. players     target      <- arbitraryPlayer game      return $ if isJust (game ^. see)-        then noopCommand-        else seeCommand (seer ^. name) (target ^. name)+        then Blind noopCommand+        else Blind $ seeCommand (seer ^. name) (target ^. name)  runArbitraryCommands :: Int -> Game -> Gen Game runArbitraryCommands n = iterateM n $ \game -> do-    command <- arbitraryCommand game+    (Blind command) <- arbitraryCommand game      return $ run_ (apply command) game -runArbitraryDevourVoteCommands :: Game -> Gen Game-runArbitraryDevourVoteCommands game = do-    let game'   = game { _stage = WerewolvesTurn }-    let n       = length . filterWerewolves $ game' ^. players--    runArbitraryCommands n game'- iterateM :: Monad m => Int -> (a -> m a) -> a -> m a iterateM 0 _ a = return a iterateM n f a = f a >>= iterateM (n - 1) f  arbitraryPlayer :: Game -> Gen Player-arbitraryPlayer = elements . filterAlive . _players--arbitraryDefender :: Game -> Gen Player-arbitraryDefender = elements . filterAlive . filterDefenders . _players--arbitrarySeer :: Game -> Gen Player-arbitrarySeer = elements . filterAlive . filterSeers . _players+arbitraryPlayer = elements . filterAlive . view players  arbitraryWerewolf :: Game -> Gen Player-arbitraryWerewolf = elements . filterAlive . filterWerewolves . _players--arbitraryWitch :: Game -> Gen Player-arbitraryWitch = elements . filterAlive . filterWitches . _players+arbitraryWerewolf = elements . filterAlive . filterWerewolves . view players

@@ -75,7 +75,6 @@ import           Data.Maybe  import Game.Werewolf.Command-import Game.Werewolf.Engine         (checkStage) import Game.Werewolf.Game import Game.Werewolf.Player import Game.Werewolf.Test.Arbitrary@@ -83,26 +82,28 @@  import Test.QuickCheck -prop_devourVoteCommandErrorsWhenGameIsOver :: Game -> Property-prop_devourVoteCommandErrorsWhenGameIsOver game =-    forAll (arbitraryDevourVoteCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+prop_devourVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_devourVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_devourVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_devourVoteCommandErrorsWhenCallerDoesNotExist game caller =+prop_devourVoteCommandErrorsWhenCallerDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property+prop_devourVoteCommandErrorsWhenCallerDoesNotExist (GameAtWerewolvesTurn game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))-    ==> forAll (arbitraryPlayer game) $ \target ->-        verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))+    ==> forAll (arbitraryPlayer game) $ \target -> do+        let command = devourVoteCommand (caller ^. name) (target ^. name) -prop_devourVoteCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property-prop_devourVoteCommandErrorsWhenTargetDoesNotExist game target =+        verbose_runCommandErrors game command++prop_devourVoteCommandErrorsWhenTargetDoesNotExist :: GameAtWerewolvesTurn -> Player -> Property+prop_devourVoteCommandErrorsWhenTargetDoesNotExist (GameAtWerewolvesTurn game) target =     not (doesPlayerExist (target ^. name) (game ^. players))-    ==> forAll (arbitraryWerewolf game) $ \caller ->-        verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))+    ==> forAll (arbitraryWerewolf game) $ \caller -> do+        let command = devourVoteCommand (caller ^. name) (target ^. name) -prop_devourVoteCommandErrorsWhenCallerIsDead :: Game -> Property-prop_devourVoteCommandErrorsWhenCallerIsDead game =+        verbose_runCommandErrors game command++prop_devourVoteCommandErrorsWhenCallerIsDead :: GameAtWerewolvesTurn -> Property+prop_devourVoteCommandErrorsWhenCallerIsDead (GameAtWerewolvesTurn game) =     forAll (arbitraryWerewolf game) $ \caller ->     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game caller@@ -110,8 +111,8 @@          verbose_runCommandErrors game' command -prop_devourVoteCommandErrorsWhenTargetIsDead :: Game -> Property-prop_devourVoteCommandErrorsWhenTargetIsDead game =+prop_devourVoteCommandErrorsWhenTargetIsDead :: GameAtWerewolvesTurn -> Property+prop_devourVoteCommandErrorsWhenTargetIsDead (GameAtWerewolvesTurn game) =     forAll (arbitraryWerewolf game) $ \caller ->     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game target@@ -122,119 +123,117 @@ prop_devourVoteCommandErrorsWhenNotWerewolvesTurn :: Game -> Property prop_devourVoteCommandErrorsWhenNotWerewolvesTurn game =     not (isWerewolvesTurn game)-    ==> forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game+    ==> forAll (arbitraryDevourVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_devourVoteCommandErrorsWhenCallerNotWerewolf :: Game -> Property-prop_devourVoteCommandErrorsWhenCallerNotWerewolf game =+prop_devourVoteCommandErrorsWhenCallerNotWerewolf :: GameAtWerewolvesTurn -> Property+prop_devourVoteCommandErrorsWhenCallerNotWerewolf (GameAtWerewolvesTurn game) =     forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \caller ->-    forAll (arbitraryPlayer game) $ \target ->-    verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name))+    forAll (arbitraryPlayer game) $ \target -> do+        let command = devourVoteCommand (caller ^. name) (target ^. name) -prop_devourVoteCommandErrorsWhenCallerHasVoted :: Game -> Property-prop_devourVoteCommandErrorsWhenCallerHasVoted game =-    forAll (arbitraryWerewolf game') $ \caller ->-    forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target -> do+        verbose_runCommandErrors game command++prop_devourVoteCommandErrorsWhenCallerHasVoted :: GameWithDevourVotes -> Property+prop_devourVoteCommandErrorsWhenCallerHasVoted (GameWithDevourVotes game) =+    forAll (arbitraryWerewolf game) $ \caller ->+    forAll (suchThat (arbitraryPlayer game) (not . isWerewolf)) $ \target -> do         let command = devourVoteCommand (caller ^. name) (target ^. name)-        let game''  = run_ (apply command) game' -        verbose_runCommandErrors game'' command-    where-        game' = game { _stage = WerewolvesTurn }+        verbose_runCommandErrors game command -prop_devourVoteCommandErrorsWhenTargetWerewolf :: Game -> Property-prop_devourVoteCommandErrorsWhenTargetWerewolf game =+prop_devourVoteCommandErrorsWhenTargetWerewolf :: GameAtWerewolvesTurn -> Property+prop_devourVoteCommandErrorsWhenTargetWerewolf (GameAtWerewolvesTurn game) =     forAll (suchThat (arbitraryPlayer game) isWerewolf) $ \target ->     forAll (arbitraryPlayer game) $ \caller ->     verbose_runCommandErrors game (devourVoteCommand (caller ^. name) (target ^. name)) -prop_devourVoteCommandUpdatesVotes :: Game -> Property-prop_devourVoteCommandUpdatesVotes game =-    forAll (arbitraryDevourVoteCommand game') $ \command -> do-        let game'' = run_ (apply command) game'+prop_devourVoteCommandUpdatesVotes :: GameAtWerewolvesTurn -> Property+prop_devourVoteCommandUpdatesVotes (GameAtWerewolvesTurn game) =+    forAll (arbitraryDevourVoteCommand game) $ \(Blind command) -> do+        let game' = run_ (apply command) game -        Map.size (game'' ^. votes) == 1-    where-        game' = game { _stage = WerewolvesTurn }+        Map.size (game' ^. votes) == 1 -prop_healCommandErrorsWhenGameIsOver :: Game -> Property-prop_healCommandErrorsWhenGameIsOver game =-    forAll (arbitraryWitch game') $ \witch ->-    verbose_runCommandErrors game' (healCommand $ witch ^. name)-    where-        game' = game { _stage = GameOver }+prop_healCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_healCommandErrorsWhenGameIsOver (GameAtGameOver game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = healCommand $ witch ^. name -prop_healCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_healCommandErrorsWhenCallerDoesNotExist game caller =+    verbose_runCommandErrors game command++prop_healCommandErrorsWhenCallerDoesNotExist :: GameWithDevourEvent -> Player -> Property+prop_healCommandErrorsWhenCallerDoesNotExist (GameWithDevourEvent game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))     ==> verbose_runCommandErrors game (healCommand (caller ^. name)) -prop_healCommandErrorsWhenCallerIsDead :: Game -> Property-prop_healCommandErrorsWhenCallerIsDead game =+prop_healCommandErrorsWhenCallerIsDead :: GameWithDevourEvent -> Property+prop_healCommandErrorsWhenCallerIsDead (GameWithDevourEvent game) =     forAll (arbitraryPlayer game) $ \caller -> do         let game'   = killPlayer game caller         let command = healCommand (caller ^. name)          verbose_runCommandErrors game' command -prop_healCommandErrorsWhenNoTargetIsDevoured :: Game -> Property-prop_healCommandErrorsWhenNoTargetIsDevoured game =-    forAll (arbitraryWitch game) $ \witch ->-    verbose_runCommandErrors game (healCommand $ witch ^. name)+prop_healCommandErrorsWhenNoTargetIsDevoured :: GameAtWitchsTurn -> Property+prop_healCommandErrorsWhenNoTargetIsDevoured (GameAtWitchsTurn game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = healCommand $ witch ^. name +    verbose_runCommandErrors game command+ prop_healCommandErrorsWhenNotWitchsTurn :: Game -> Property-prop_healCommandErrorsWhenNotWitchsTurn game =-    not (isWitchsTurn game)-    ==> forAll (arbitraryWitch game) $ \witch ->-        verbose_runCommandErrors game (healCommand $ witch ^. name)+prop_healCommandErrorsWhenNotWitchsTurn game = do+    let witch   = head . filterWitches $ game ^. players+    let command = healCommand $ witch ^. name -prop_healCommandErrorsWhenCallerHasHealed :: Gen Property-prop_healCommandErrorsWhenCallerHasHealed = do-    game <- arbitraryGameWithDevourEventForVillager+    not (isWitchsTurn game) ==> verbose_runCommandErrors game command -    return $ forAll (arbitraryHealCommand game) $ \command -> do-        let game' = run_ (apply command) game+prop_healCommandErrorsWhenCallerHasHealed :: GameWithHeal -> Property+prop_healCommandErrorsWhenCallerHasHealed (GameWithHeal game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = healCommand $ witch ^. name -        verbose_runCommandErrors game' command+    verbose_runCommandErrors game command -prop_healCommandErrorsWhenCallerNotWitch :: Game -> Property-prop_healCommandErrorsWhenCallerNotWitch game =-    forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller ->-    verbose_runCommandErrors game (healCommand (caller ^. name))+prop_healCommandErrorsWhenCallerNotWitch :: GameWithDevourEvent -> Property+prop_healCommandErrorsWhenCallerNotWitch (GameWithDevourEvent game) =+    forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller -> do+        let command = healCommand (caller ^. name) -prop_healCommandSetsHeal :: Gen Property-prop_healCommandSetsHeal = do-    game <- arbitraryGameWithDevourEventForVillager+        verbose_runCommandErrors game command -    return $ forAll (arbitraryHealCommand game) $ \command ->+prop_healCommandSetsHeal :: GameWithDevourEvent -> Property+prop_healCommandSetsHeal (GameWithDevourEvent game) =+    forAll (arbitraryHealCommand game) $ \(Blind command) ->         (run_ (apply command) game) ^. heal -prop_healCommandSetsHealUsed :: Gen Property-prop_healCommandSetsHealUsed = do-    game <- arbitraryGameWithDevourEventForVillager--    return $ forAll (arbitraryHealCommand game) $ \command ->+prop_healCommandSetsHealUsed :: GameWithDevourEvent -> Property+prop_healCommandSetsHealUsed (GameWithDevourEvent game) =+    forAll (arbitraryHealCommand game) $ \(Blind command) ->         (run_ (apply command) game) ^. healUsed -prop_lynchVoteCommandErrorsWhenGameIsOver :: Game -> Property-prop_lynchVoteCommandErrorsWhenGameIsOver game =-    forAll (arbitraryLynchVoteCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+prop_lynchVoteCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_lynchVoteCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_lynchVoteCommandErrorsWhenCallerDoesNotExist game caller =+prop_lynchVoteCommandErrorsWhenCallerDoesNotExist :: GameAtVillagesTurn -> Player -> Property+prop_lynchVoteCommandErrorsWhenCallerDoesNotExist (GameAtVillagesTurn game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))-    ==> forAll (arbitraryPlayer game) $ \target ->-        verbose_runCommandErrors game (lynchVoteCommand (caller ^. name) (target ^. name))+    ==> forAll (arbitraryPlayer game) $ \target -> do+        let command = lynchVoteCommand (caller ^. name) (target ^. name) -prop_lynchVoteCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property-prop_lynchVoteCommandErrorsWhenTargetDoesNotExist game target =+        verbose_runCommandErrors game command++prop_lynchVoteCommandErrorsWhenTargetDoesNotExist :: GameAtVillagesTurn -> Player -> Property+prop_lynchVoteCommandErrorsWhenTargetDoesNotExist (GameAtVillagesTurn game) target =     not (doesPlayerExist (target ^. name) (game ^. players))-    ==> forAll (arbitraryPlayer game) $ \caller ->-        verbose_runCommandErrors game (lynchVoteCommand (caller ^. name) (target ^. name))+    ==> forAll (arbitraryPlayer game) $ \caller -> do+        let command = lynchVoteCommand (caller ^. name) (target ^. name) -prop_lynchVoteCommandErrorsWhenCallerIsDead :: Game -> Property-prop_lynchVoteCommandErrorsWhenCallerIsDead game =+        verbose_runCommandErrors game command++prop_lynchVoteCommandErrorsWhenCallerIsDead :: GameAtVillagesTurn -> Property+prop_lynchVoteCommandErrorsWhenCallerIsDead (GameAtVillagesTurn game) =     forAll (arbitraryPlayer game) $ \caller ->     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game caller@@ -242,8 +241,8 @@          verbose_runCommandErrors game' command -prop_lynchVoteCommandErrorsWhenTargetIsDead :: Game -> Property-prop_lynchVoteCommandErrorsWhenTargetIsDead game =+prop_lynchVoteCommandErrorsWhenTargetIsDead :: GameAtVillagesTurn -> Property+prop_lynchVoteCommandErrorsWhenTargetIsDead (GameAtVillagesTurn game) =     forAll (arbitraryPlayer game) $ \caller ->     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game target@@ -254,41 +253,34 @@ prop_lynchVoteCommandErrorsWhenNotVillagesTurn :: Game -> Property prop_lynchVoteCommandErrorsWhenNotVillagesTurn game =     not (isVillagesTurn game)-    ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game+    ==> forAll (arbitraryLynchVoteCommand game) $ verbose_runCommandErrors game . getBlind -prop_lynchVoteCommandErrorsWhenCallerHasVoted :: Game -> Property-prop_lynchVoteCommandErrorsWhenCallerHasVoted game =-    forAll (arbitraryPlayer game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target -> do+prop_lynchVoteCommandErrorsWhenCallerHasVoted :: GameWithLynchVotes -> Property+prop_lynchVoteCommandErrorsWhenCallerHasVoted (GameWithLynchVotes game) =+    forAll (arbitraryPlayer game) $ \caller ->+    forAll (arbitraryPlayer game) $ \target -> do         let command = lynchVoteCommand (caller ^. name) (target ^. name)-        let game''  = run_ (apply command) game' -        verbose_runCommandErrors game'' command-    where-        game' = game { _stage = VillagesTurn }+        verbose_runCommandErrors game command -prop_lynchVoteCommandUpdatesVotes :: Game -> Property-prop_lynchVoteCommandUpdatesVotes game =-    forAll (arbitraryLynchVoteCommand game') $ \command -> do-        let game'' = run_ (apply command) game'+prop_lynchVoteCommandUpdatesVotes :: GameAtVillagesTurn -> Property+prop_lynchVoteCommandUpdatesVotes (GameAtVillagesTurn game) =+    forAll (arbitraryLynchVoteCommand game) $ \(Blind command) -> do+        let game' = run_ (apply command) game -        Map.size (game'' ^. votes) == 1-    where-        game' = game { _stage = VillagesTurn }+        Map.size (game' ^. votes) == 1 -prop_passCommandErrorsWhenGameIsOver :: Game -> Property-prop_passCommandErrorsWhenGameIsOver game =-    forAll (arbitraryPassCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+prop_passCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_passCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind -prop_passCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_passCommandErrorsWhenCallerDoesNotExist game caller =+prop_passCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property+prop_passCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))     ==> verbose_runCommandErrors game (passCommand (caller ^. name)) -prop_passCommandErrorsWhenCallerIsDead :: Game -> Property-prop_passCommandErrorsWhenCallerIsDead game =+prop_passCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property+prop_passCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) =     forAll (arbitraryPlayer game) $ \caller -> do         let game'   = killPlayer game caller         let command = passCommand (caller ^. name)@@ -298,188 +290,178 @@ prop_passCommandErrorsWhenNotWitchsTurn :: Game -> Property prop_passCommandErrorsWhenNotWitchsTurn game =     not (isWitchsTurn game)-    ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game+    ==> forAll (arbitraryPassCommand game) $ verbose_runCommandErrors game . getBlind -prop_passCommandUpdatesPasses :: Game -> Property-prop_passCommandUpdatesPasses game =-    forAll (arbitraryPassCommand game') $ \command -> do-        let game'' = run_ (apply command) game'+prop_passCommandUpdatesPasses :: GameAtWitchsTurn -> Property+prop_passCommandUpdatesPasses (GameAtWitchsTurn game) =+    forAll (arbitraryPassCommand game) $ \(Blind command) -> do+        let game' = run_ (apply command) game -        length (game'' ^. passes) == 1-    where-        game' = game { _stage = WitchsTurn }+        length (game' ^. passes) == 1 -prop_poisonCommandErrorsWhenGameIsOver :: Game -> Property-prop_poisonCommandErrorsWhenGameIsOver game =-    forAll (arbitraryPoisonCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+prop_poisonCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_poisonCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind -prop_poisonCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_poisonCommandErrorsWhenCallerDoesNotExist game caller =+prop_poisonCommandErrorsWhenCallerDoesNotExist :: GameAtWitchsTurn -> Player -> Property+prop_poisonCommandErrorsWhenCallerDoesNotExist (GameAtWitchsTurn game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))-    ==> forAll (arbitraryPlayer game) $ \target ->-        verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name))+    ==> forAll (arbitraryPlayer game) $ \target -> do+        let command = poisonCommand (caller ^. name) (target ^. name) -prop_poisonCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property-prop_poisonCommandErrorsWhenTargetDoesNotExist game target =+        verbose_runCommandErrors game command++prop_poisonCommandErrorsWhenTargetDoesNotExist :: GameAtWitchsTurn -> Player -> Property+prop_poisonCommandErrorsWhenTargetDoesNotExist (GameAtWitchsTurn game) target = do+    let witch   = head . filterWitches $ game ^. players+    let command = poisonCommand (witch ^. name) (target ^. name)+     not (doesPlayerExist (target ^. name) (game ^. players))-    ==> forAll (arbitraryPlayer game) $ \caller ->-        verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name))+        ==> verbose_runCommandErrors game command -prop_poisonCommandErrorsWhenCallerIsDead :: Game -> Property-prop_poisonCommandErrorsWhenCallerIsDead game =-    forAll (arbitraryPlayer game) $ \caller ->+prop_poisonCommandErrorsWhenCallerIsDead :: GameAtWitchsTurn -> Property+prop_poisonCommandErrorsWhenCallerIsDead (GameAtWitchsTurn game) = do+    let witch = head . filterWitches $ game ^. players+     forAll (arbitraryPlayer game) $ \target -> do-        let game'   = killPlayer game caller-        let command = poisonCommand (caller ^. name) (target ^. name)+        let game'   = killPlayer game witch+        let command = poisonCommand (witch ^. name) (target ^. name)          verbose_runCommandErrors game' command -prop_poisonCommandErrorsWhenTargetIsDead :: Game -> Property-prop_poisonCommandErrorsWhenTargetIsDead game =-    forAll (arbitraryPlayer game) $ \caller ->+prop_poisonCommandErrorsWhenTargetIsDead :: GameAtWitchsTurn -> Property+prop_poisonCommandErrorsWhenTargetIsDead (GameAtWitchsTurn game) = do+    let witch = head . filterWitches $ game ^. players+     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game target-        let command = poisonCommand (caller ^. name) (target ^. name)+        let command = poisonCommand (witch ^. name) (target ^. name)          verbose_runCommandErrors game' command -prop_poisonCommandErrorsWhenTargetIsDevoured :: Game -> Property-prop_poisonCommandErrorsWhenTargetIsDevoured game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> forAll (arbitraryWitch game'') $ \caller ->-        let game''' = run_ checkStage game''-            votee   = head (getVoteResult game'')-        in verbose_runCommandErrors game''' (poisonCommand (caller ^. name) (votee ^. name))-    where-        game'   = game { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+prop_poisonCommandErrorsWhenTargetIsDevoured :: GameWithDevourEvent -> Property+prop_poisonCommandErrorsWhenTargetIsDevoured (GameWithDevourEvent game) = do+    let (DevourEvent targetName) = fromJust $ getDevourEvent game +    let witch   = head . filterWitches $ game ^. players+    let command = poisonCommand (witch ^. name) targetName++    verbose_runCommandErrors game command+ prop_poisonCommandErrorsWhenNotWitchsTurn :: Game -> Property prop_poisonCommandErrorsWhenNotWitchsTurn game =     not (isWitchsTurn game)-    ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game+    ==> forAll (arbitraryPoisonCommand game) $ verbose_runCommandErrors game . getBlind -prop_poisonCommandErrorsWhenCallerHasPoisoned :: Game -> Property-prop_poisonCommandErrorsWhenCallerHasPoisoned game =-    forAll (arbitraryWitch game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target ->-    let command = poisonCommand (caller ^. name) (target ^. name)-    in verbose_runCommandErrors (run_ (apply command) game') command-    where-        game' = game { _stage = WitchsTurn }+prop_poisonCommandErrorsWhenCallerHasPoisoned :: GameWithPoison -> Property+prop_poisonCommandErrorsWhenCallerHasPoisoned (GameWithPoison game) = do+    let witch = head . filterWitches $ game ^. players -prop_poisonCommandErrorsWhenCallerNotWitch :: Game -> Property-prop_poisonCommandErrorsWhenCallerNotWitch game =+    forAll (arbitraryPlayer game) $ \target -> do+        let command = poisonCommand (witch ^. name) (target ^. name)++        verbose_runCommandErrors game command++prop_poisonCommandErrorsWhenCallerNotWitch :: GameAtWitchsTurn -> Property+prop_poisonCommandErrorsWhenCallerNotWitch (GameAtWitchsTurn game) =     forAll (suchThat (arbitraryPlayer game) (not . isWitch)) $ \caller ->-    forAll (arbitraryPlayer game) $ \target ->-    verbose_runCommandErrors game (poisonCommand (caller ^. name) (target ^. name))+    forAll (arbitraryPlayer game) $ \target -> do+        let command = poisonCommand (caller ^. name) (target ^. name) -prop_poisonCommandSetsPoison :: Game -> Property-prop_poisonCommandSetsPoison game =-    forAll (arbitraryPoisonCommand game') $ \command ->-    isJust (run_ (apply command) game' ^. poison)-    where-        game' = game { _stage = WitchsTurn }+        verbose_runCommandErrors game command -prop_poisonCommandSetsPoisonUsed :: Game -> Property-prop_poisonCommandSetsPoisonUsed game =-    forAll (arbitraryPoisonCommand game') $ \command ->-    run_ (apply command) game' ^. poisonUsed-    where-        game' = game { _stage = WitchsTurn }+prop_poisonCommandSetsPoison :: GameAtWitchsTurn -> Property+prop_poisonCommandSetsPoison (GameAtWitchsTurn game) =+    forAll (arbitraryPoisonCommand game) $ \(Blind command) ->+    isJust (run_ (apply command) game ^. poison) -prop_protectCommandErrorsWhenGameIsOver :: Game -> Property-prop_protectCommandErrorsWhenGameIsOver game =-    forAll (arbitraryProtectCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+prop_poisonCommandSetsPoisonUsed :: GameAtWitchsTurn -> Property+prop_poisonCommandSetsPoisonUsed (GameAtWitchsTurn game) =+    forAll (arbitraryPoisonCommand game) $ \(Blind command) ->+    run_ (apply command) game ^. poisonUsed -prop_protectCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_protectCommandErrorsWhenCallerDoesNotExist game caller =+prop_protectCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_protectCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind++prop_protectCommandErrorsWhenCallerDoesNotExist :: GameAtDefendersTurn -> Player -> Property+prop_protectCommandErrorsWhenCallerDoesNotExist (GameAtDefendersTurn game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))     ==> forAll (arbitraryPlayer game) $ \target -> do         let command = protectCommand (caller ^. name) (target ^. name)          verbose_runCommandErrors game command -prop_protectCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property-prop_protectCommandErrorsWhenTargetDoesNotExist game target =+prop_protectCommandErrorsWhenTargetDoesNotExist :: GameAtDefendersTurn -> Player -> Property+prop_protectCommandErrorsWhenTargetDoesNotExist (GameAtDefendersTurn game) target = do+    let defender    = head . filterDefenders $ game ^. players+    let command     = protectCommand (defender ^. name) (target ^. name)+     not (doesPlayerExist (target ^. name) (game ^. players))-    ==> forAll (arbitraryDefender game) $ \caller -> do-        let command = protectCommand (caller ^. name) (target ^. name)+        ==> verbose_runCommandErrors game command -        verbose_runCommandErrors game command+prop_protectCommandErrorsWhenCallerIsDead :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenCallerIsDead (GameAtDefendersTurn game) = do+    let defender    = head . filterDefenders $ game ^. players+    let game'       = killPlayer game defender -prop_protectCommandErrorsWhenCallerIsDead :: Game -> Property-prop_protectCommandErrorsWhenCallerIsDead game =-    forAll (arbitraryDefender game) $ \caller ->-    forAll (arbitraryPlayer game) $ \target -> do-        let game'   = killPlayer game caller-        let command = protectCommand (caller ^. name) (target ^. name)+    forAll (arbitraryPlayer game') $ \target -> do+        let command = protectCommand (defender ^. name) (target ^. name)          verbose_runCommandErrors game' command -prop_protectCommandErrorsWhenTargetIsDead :: Game -> Property-prop_protectCommandErrorsWhenTargetIsDead game =-    forAll (arbitraryDefender game) $ \caller ->+prop_protectCommandErrorsWhenTargetIsDead :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenTargetIsDead (GameAtDefendersTurn game) = do+    let defender = head . filterDefenders $ game ^. players+     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game target-        let command = protectCommand (caller ^. name) (target ^. name)+        let command = protectCommand (defender ^. name) (target ^. name)          verbose_runCommandErrors game' command  prop_protectCommandErrorsWhenNotDefendersTurn :: Game -> Property prop_protectCommandErrorsWhenNotDefendersTurn game =     not (isDefendersTurn game)-    ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game+    ==> forAll (arbitraryProtectCommand game) $ verbose_runCommandErrors game . getBlind -prop_protectCommandErrorsWhenCallerNotDefender :: Game -> Property-prop_protectCommandErrorsWhenCallerNotDefender game =+prop_protectCommandErrorsWhenCallerNotDefender :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenCallerNotDefender (GameAtDefendersTurn game) =     forAll (suchThat (arbitraryPlayer game) (not . isDefender)) $ \caller ->     forAll (arbitraryPlayer game) $ \target -> do         let command = protectCommand (caller ^. name) (target ^. name)          verbose_runCommandErrors game command -prop_protectCommandErrorsWhenTargetIsCaller :: Game -> Property-prop_protectCommandErrorsWhenTargetIsCaller game =-    forAll (arbitraryDefender game) $ \caller -> do-        let command = protectCommand (caller ^. name) (caller ^. name)+prop_protectCommandErrorsWhenTargetIsCaller :: GameAtDefendersTurn -> Property+prop_protectCommandErrorsWhenTargetIsCaller (GameAtDefendersTurn game) = do+    let defender    = head . filterDefenders $ game ^. players+    let command     = protectCommand (defender ^. name) (defender ^. name) -        verbose_runCommandErrors game command+    verbose_runCommandErrors game command -prop_protectCommandErrorsWhenTargetIsPriorProtect :: Gen Property-prop_protectCommandErrorsWhenTargetIsPriorProtect = do-    game <- arbitraryGameWithProtect-    let game' = game { _protect = Nothing }+prop_protectCommandErrorsWhenTargetIsPriorProtect :: GameWithProtect -> Property+prop_protectCommandErrorsWhenTargetIsPriorProtect (GameWithProtect game) = do+    let game' = game & protect .~ Nothing -    return $ forAll (arbitraryDefender game') $ \caller -> do-        let command = protectCommand (caller ^. name) (fromJust $ game' ^. priorProtect)+    let defender    = head . filterDefenders $ game' ^. players+    let command     = protectCommand (defender ^. name) (fromJust $ game' ^. priorProtect) -        verbose_runCommandErrors game' command+    verbose_runCommandErrors game' command -prop_protectCommandSetsPriorProtect :: Game -> Property-prop_protectCommandSetsPriorProtect game =-    forAll (arbitraryProtectCommand game') $ \command ->-    isJust $ run_ (apply command) game' ^. priorProtect-    where-        game' = game { _stage = DefendersTurn }+prop_protectCommandSetsPriorProtect :: GameAtDefendersTurn -> Property+prop_protectCommandSetsPriorProtect (GameAtDefendersTurn game) =+    forAll (arbitraryProtectCommand game) $ \(Blind command) ->+    isJust $ run_ (apply command) game ^. priorProtect -prop_protectCommandSetsProtect :: Game -> Property-prop_protectCommandSetsProtect game =-    forAll (arbitraryProtectCommand game') $ \command ->-    isJust $ run_ (apply command) game' ^. protect-    where-        game' = game { _stage = DefendersTurn }+prop_protectCommandSetsProtect :: GameAtDefendersTurn -> Property+prop_protectCommandSetsProtect (GameAtDefendersTurn game) =+    forAll (arbitraryProtectCommand game) $ \(Blind command) ->+    isJust $ run_ (apply command) game ^. protect -prop_quitCommandErrorsWhenGameIsOver :: Game -> Property-prop_quitCommandErrorsWhenGameIsOver game =-    forAll (arbitraryQuitCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+prop_quitCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_quitCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitraryQuitCommand game) $ verbose_runCommandErrors game . getBlind  prop_quitCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property prop_quitCommandErrorsWhenCallerDoesNotExist game caller =@@ -488,160 +470,136 @@  prop_quitCommandErrorsWhenCallerIsDead :: Game -> Property prop_quitCommandErrorsWhenCallerIsDead game =-    forAll (arbitraryPlayer game) $ \caller ->-    verbose_runCommandErrors (killPlayer game caller) (quitCommand $ caller ^. name)+    forAll (arbitraryPlayer game) $ \caller -> do+        let game'   = killPlayer game caller+        let command = quitCommand $ caller ^. name +        verbose_runCommandErrors game' command+ prop_quitCommandKillsPlayer :: Game -> Property prop_quitCommandKillsPlayer game =     not (isGameOver game)-    ==> forAll (arbitraryQuitCommand game) $ \command ->-        length (filterDead $ run_ (apply command) game ^. players) == 1+    ==> forAll (arbitraryQuitCommand game) $ \(Blind command) -> do+        let game' = run_ (apply command) game -prop_quitCommandClearsHealWhenCallerIsWitch :: Game -> Property-prop_quitCommandClearsHealWhenCallerIsWitch game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> let target = head $ getVoteResult game''-        in not (isWitch target)-        ==> forAll (arbitraryWitch game'') $ \caller ->-            let command = healCommand (caller ^. name)-                game''' = run_ (apply command) $ run_ checkStage game''-            in not $ run_ (apply $ quitCommand (caller ^. name)) game''' ^. heal-    where-        game'   = game { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+        length (filterDead $ game' ^. players) == 1 -prop_quitCommandClearsHealUsedWhenCallerIsWitch :: Game -> Property-prop_quitCommandClearsHealUsedWhenCallerIsWitch game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> let target = head $ getVoteResult game''-        in not (isWitch target)-        ==> forAll (arbitraryWitch game'') $ \caller ->-            let command = healCommand (caller ^. name)-                game''' = run_ (apply command) $ run_ checkStage game''-            in not $ run_ (apply $ quitCommand (caller ^. name)) game''' ^. healUsed-    where-        game'   = game { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+prop_quitCommandClearsHealWhenCallerIsWitch :: GameWithHeal -> Bool+prop_quitCommandClearsHealWhenCallerIsWitch (GameWithHeal game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = quitCommand (witch ^. name) -prop_quitCommandClearsPoisonWhenCallerIsWitch :: Game -> Property-prop_quitCommandClearsPoisonWhenCallerIsWitch game =-    forAll (arbitraryWitch game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target ->-    let game'' = run_ (apply $ poisonCommand (caller ^. name) (target ^. name)) game'-    in isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. poison-    where-        game' = game { _stage = WitchsTurn }+    not $ run_ (apply command) game ^. heal -prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: Game -> Property-prop_quitCommandClearsPriorProtectWhenCallerIsDefender game =-    forAll (arbitraryDefender game') $ \caller ->-    forAll (suchThat (arbitraryPlayer game') (not . isDefender)) $ \target -> do-        let command = protectCommand (caller ^. name) (target ^. name)-        let game''  = run_ (apply command) game'+prop_quitCommandClearsHealUsedWhenCallerIsWitch :: GameWithHeal -> Bool+prop_quitCommandClearsHealUsedWhenCallerIsWitch (GameWithHeal game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = quitCommand (witch ^. name) -        isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. priorProtect-    where-        game' = game { _stage = DefendersTurn }+    not $ run_ (apply command) game ^. healUsed -prop_quitCommandClearsProtectWhenCallerIsDefender :: Game -> Property-prop_quitCommandClearsProtectWhenCallerIsDefender game =-    forAll (arbitraryDefender game') $ \caller ->-    forAll (suchThat (arbitraryPlayer game') (not . isDefender)) $ \target -> do-        let command = protectCommand (caller ^. name) (target ^. name)-        let game''  = run_ (apply command) game'+prop_quitCommandClearsPoisonWhenCallerIsWitch :: GameWithPoison -> Bool+prop_quitCommandClearsPoisonWhenCallerIsWitch (GameWithPoison game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = quitCommand (witch ^. name) -        isNothing $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. protect-    where-        game' = game { _stage = DefendersTurn }+    isNothing $ run_ (apply command) game ^. poison -prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: Game -> Property-prop_quitCommandClearsPoisonUsedWhenCallerIsWitch game =-    forAll (arbitraryWitch game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target ->-    let game'' = run_ (apply $ poisonCommand (caller ^. name) (target ^. name)) game'-    in not $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. poisonUsed-    where-        game' = game { _stage = WitchsTurn }+prop_quitCommandClearsPoisonUsedWhenCallerIsWitch :: GameWithPoison -> Bool+prop_quitCommandClearsPoisonUsedWhenCallerIsWitch (GameWithPoison game) = do+    let witch   = head . filterWitches $ game ^. players+    let command = quitCommand (witch ^. name) -prop_quitCommandClearsPlayersDevourVote :: Game -> Property-prop_quitCommandClearsPlayersDevourVote game =-    forAll (arbitraryWerewolf game') $ \caller ->-    forAll (suchThat (arbitraryPlayer game') (not . isWerewolf)) $ \target ->-    let game'' = run_ (apply $ devourVoteCommand (caller ^. name) (target ^. name)) game'-    in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes-    where-        game' = game { _stage = WerewolvesTurn }+    not $ run_ (apply command) game ^. poisonUsed -prop_quitCommandClearsPlayersLynchVote :: Game -> Property-prop_quitCommandClearsPlayersLynchVote game =-    forAll (arbitraryPlayer game') $ \caller ->-    forAll (arbitraryPlayer game') $ \target ->-    let game'' = run_ (apply $ lynchVoteCommand (caller ^. name) (target ^. name)) game'-        in Map.null $ run_ (apply $ quitCommand (caller ^. name)) game'' ^. votes-    where-        game' = game { _stage = VillagesTurn }+prop_quitCommandClearsPriorProtectWhenCallerIsDefender :: GameWithProtect -> Bool+prop_quitCommandClearsPriorProtectWhenCallerIsDefender (GameWithProtect game) = do+    let defender    = head . filterDefenders $ game ^. players+    let command     = quitCommand (defender ^. name) -prop_seeCommandErrorsWhenGameIsOver :: Game -> Property-prop_seeCommandErrorsWhenGameIsOver game =-    forAll (arbitrarySeeCommand game') $ verbose_runCommandErrors game'-    where-        game' = game { _stage = GameOver }+    isNothing $ run_ (apply command) game ^. priorProtect -prop_seeCommandErrorsWhenCallerDoesNotExist :: Game -> Player -> Property-prop_seeCommandErrorsWhenCallerDoesNotExist game caller =+prop_quitCommandClearsProtectWhenCallerIsDefender :: GameWithProtect -> Bool+prop_quitCommandClearsProtectWhenCallerIsDefender (GameWithProtect game) = do+    let defender    = head . filterDefenders $ game ^. players+    let command     = quitCommand (defender ^. name)++    isNothing $ run_ (apply command) game ^. protect++prop_quitCommandClearsPlayersDevourVote :: GameWithDevourVotes -> Property+prop_quitCommandClearsPlayersDevourVote (GameWithDevourVotes game) =+    forAll (arbitraryWerewolf game) $ \caller -> do+        let command = quitCommand (caller ^. name)++        isNothing $ run_ (apply command) game ^. votes . at (caller ^. name)++prop_quitCommandClearsPlayersLynchVote :: GameWithLynchVotes -> Property+prop_quitCommandClearsPlayersLynchVote (GameWithLynchVotes game) =+    forAll (arbitraryPlayer game) $ \caller -> do+        let command = quitCommand (caller ^. name)++        isNothing $ run_ (apply command) game ^. votes . at (caller ^. name)++prop_seeCommandErrorsWhenGameIsOver :: GameAtGameOver -> Property+prop_seeCommandErrorsWhenGameIsOver (GameAtGameOver game) =+    forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind++prop_seeCommandErrorsWhenCallerDoesNotExist :: GameAtSeersTurn -> Player -> Property+prop_seeCommandErrorsWhenCallerDoesNotExist (GameAtSeersTurn game) caller =     not (doesPlayerExist (caller ^. name) (game ^. players))     ==> forAll (arbitraryPlayer game) $ \target -> do         let command = seeCommand (caller ^. name) (target ^. name)          verbose_runCommandErrors game command -prop_seeCommandErrorsWhenTargetDoesNotExist :: Game -> Player -> Property-prop_seeCommandErrorsWhenTargetDoesNotExist game target =+prop_seeCommandErrorsWhenTargetDoesNotExist :: GameAtSeersTurn -> Player -> Property+prop_seeCommandErrorsWhenTargetDoesNotExist (GameAtSeersTurn game) target = do+    let seer    = head . filterSeers $ game ^. players+    let command = seeCommand (seer ^. name) (target ^. name)+     not (doesPlayerExist (target ^. name) (game ^. players))-    ==> forAll (arbitrarySeer game) $ \caller -> do-        let command = seeCommand (caller ^. name) (target ^. name)+        ==> verbose_runCommandErrors game command -        verbose_runCommandErrors game command+prop_seeCommandErrorsWhenCallerIsDead :: GameAtSeersTurn -> Property+prop_seeCommandErrorsWhenCallerIsDead (GameAtSeersTurn game) = do+    let seer    = head . filterSeers $ game ^. players+    let game'   = killPlayer game seer -prop_seeCommandErrorsWhenCallerIsDead :: Game -> Property-prop_seeCommandErrorsWhenCallerIsDead game =-    forAll (arbitrarySeer game) $ \caller ->-    forAll (arbitraryPlayer game) $ \target -> do-        let game'   = killPlayer game caller-        let command = seeCommand (caller ^. name) (target ^. name)+    forAll (arbitraryPlayer game') $ \target -> do+        let command = seeCommand (seer ^. name) (target ^. name)          verbose_runCommandErrors game' command -prop_seeCommandErrorsWhenTargetIsDead :: Game -> Property-prop_seeCommandErrorsWhenTargetIsDead game =-    forAll (arbitrarySeer game) $ \caller ->+prop_seeCommandErrorsWhenTargetIsDead :: GameAtSeersTurn -> Property+prop_seeCommandErrorsWhenTargetIsDead (GameAtSeersTurn game) = do+    let seer = head . filterSeers $ game ^. players+     forAll (arbitraryPlayer game) $ \target -> do         let game'   = killPlayer game target-        let command = seeCommand (caller ^. name) (target ^. name)+        let command = seeCommand (seer ^. name) (target ^. name)          verbose_runCommandErrors game' command  prop_seeCommandErrorsWhenNotSeersTurn :: Game -> Property prop_seeCommandErrorsWhenNotSeersTurn game =     not (isSeersTurn game)-    ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game+    ==> forAll (arbitrarySeeCommand game) $ verbose_runCommandErrors game . getBlind -prop_seeCommandErrorsWhenCallerNotSeer :: Game -> Property-prop_seeCommandErrorsWhenCallerNotSeer game =+prop_seeCommandErrorsWhenCallerNotSeer :: GameAtSeersTurn -> Property+prop_seeCommandErrorsWhenCallerNotSeer (GameAtSeersTurn game) =     forAll (suchThat (arbitraryPlayer game) (not . isSeer)) $ \caller ->     forAll (arbitraryPlayer game) $ \target -> do         let command = seeCommand (caller ^. name) (target ^. name)          verbose_runCommandErrors game command -prop_seeCommandSetsSee :: Game -> Property-prop_seeCommandSetsSee game =-    forAll (arbitrarySeeCommand game') $ \command ->-    isJust $ run_ (apply command) game' ^. see-    where-        game' = game { _stage = SeersTurn }+prop_seeCommandSetsSee :: GameAtSeersTurn -> Property+prop_seeCommandSetsSee (GameAtSeersTurn game) =+    forAll (arbitrarySeeCommand game) $ \(Blind command) ->+    isJust $ run_ (apply command) game ^. see  verbose_runCommandErrors :: Game -> Command -> Property-verbose_runCommandErrors game command = whenFail (mapM_ putStrLn [show game, show . fromRight $ run (apply command) game]) (isLeft $ run (apply command) game)+verbose_runCommandErrors game command = whenFail (mapM_ putStrLn data_) (isLeft result)+    where+        result  = run (apply command) game+        data_   = [show game, show $ fromRight result]

@@ -24,7 +24,6 @@     prop_checkVillagesTurnDoesNothingUnlessAllVoted,      prop_checkWerewolvesTurnAdvancesToWitchsTurn,-    prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured,     prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned,     prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus,     prop_checkWerewolvesTurnKillsNoOneWhenConflicted,@@ -71,7 +70,7 @@                                                isWitchsTurn, killPlayer) import           Game.Werewolf.Game import           Game.Werewolf.Player-import           Game.Werewolf.Role           hiding (name, _name)+import           Game.Werewolf.Role           hiding (name) import qualified Game.Werewolf.Role           as Role import           Game.Werewolf.Test.Arbitrary import           Game.Werewolf.Test.Util@@ -79,190 +78,130 @@ import Test.QuickCheck import Test.QuickCheck.Monadic -prop_checkStageSkipsDefendersTurnWhenNoDefender :: Game -> Property-prop_checkStageSkipsDefendersTurnWhenNoDefender game =-    forAll (arbitrarySeeCommand game') $ \command ->-    not . isDefendersTurn $ run_ (apply command >> checkStage) game'+prop_checkStageSkipsDefendersTurnWhenNoDefender :: GameWithSee -> Bool+prop_checkStageSkipsDefendersTurnWhenNoDefender (GameWithSee game) =+    not . isDefendersTurn $ run_ checkStage game'     where-        game' = (foldl killPlayer game (filterDefenders $ game ^. players)) { _stage = SeersTurn }+        game' = foldl killPlayer game (filterDefenders $ game ^. players) -prop_checkStageSkipsSeersTurnWhenNoSeer :: Game -> Property-prop_checkStageSkipsSeersTurnWhenNoSeer game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    not . isSeersTurn $ run_ checkStage game''+prop_checkStageSkipsSeersTurnWhenNoSeer :: GameWithLynchVotes -> Bool+prop_checkStageSkipsSeersTurnWhenNoSeer (GameWithLynchVotes game) =+    not . isSeersTurn $ run_ checkStage game'     where-        game'   = (foldl killPlayer game (filterSeers $ game ^. players)) { _stage = VillagesTurn }-        n       = length $ game' ^. players+        game' = foldl killPlayer game (filterSeers $ game ^. players) -prop_checkStageSkipsWitchsTurnWhenNoWitch :: Game -> Property-prop_checkStageSkipsWitchsTurnWhenNoWitch game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    not . isWitchsTurn $ run_ checkStage game''+prop_checkStageSkipsWitchsTurnWhenNoWitch :: GameWithDevourVotes -> Bool+prop_checkStageSkipsWitchsTurnWhenNoWitch (GameWithDevourVotes game) =+    not . isWitchsTurn $ run_ checkStage game'     where-        game'   = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+        game' = foldl killPlayer game (filterWitches $ game ^. players) -prop_checkStageDoesNothingWhenGameOver :: Game -> Property-prop_checkStageDoesNothingWhenGameOver game = run_ checkStage game' === game'-    where-        game' = game { _stage = GameOver }+prop_checkStageDoesNothingWhenGameOver :: GameAtGameOver -> Property+prop_checkStageDoesNothingWhenGameOver (GameAtGameOver game) =+    run_ checkStage game === game -prop_checkDefendersTurnAdvancesToWerewolvesTurn :: Game -> Property-prop_checkDefendersTurnAdvancesToWerewolvesTurn game =-    forAll (arbitraryProtectCommand game') $ \command ->-    isWerewolvesTurn $ run_ (apply command >> checkStage) game'-    where-        game' = game { _stage = DefendersTurn }+prop_checkDefendersTurnAdvancesToWerewolvesTurn :: GameWithProtect -> Bool+prop_checkDefendersTurnAdvancesToWerewolvesTurn (GameWithProtect game) =+    isWerewolvesTurn $ run_ checkStage game -prop_checkSeersTurnAdvancesToDefendersTurn :: Game -> Property-prop_checkSeersTurnAdvancesToDefendersTurn game =-    forAll (arbitraryCommand game') $ \command ->-    isDefendersTurn $ run_ (apply command >> checkStage) game'-    where-        game' = game { _stage = SeersTurn }+prop_checkSeersTurnAdvancesToDefendersTurn :: GameWithSee -> Bool+prop_checkSeersTurnAdvancesToDefendersTurn (GameWithSee game) =+    isDefendersTurn $ run_ checkStage game -prop_checkSeersTurnResetsSee :: Game -> Property-prop_checkSeersTurnResetsSee game =-    forAll (arbitraryCommand game') $ \command ->-    isNothing $ run_ (apply command >> checkStage) game' ^. see-    where-        game' = game { _stage = SeersTurn }+prop_checkSeersTurnResetsSee :: GameWithSee -> Bool+prop_checkSeersTurnResetsSee (GameWithSee game) =+    isNothing $ run_ checkStage game ^. see -prop_checkSeersTurnDoesNothingUnlessSeen :: Game -> Bool-prop_checkSeersTurnDoesNothingUnlessSeen game = isSeersTurn $ run_ checkStage game'-    where-        game' = game { _stage = SeersTurn }+prop_checkSeersTurnDoesNothingUnlessSeen :: GameAtSeersTurn -> Bool+prop_checkSeersTurnDoesNothingUnlessSeen (GameAtSeersTurn game) =+    isSeersTurn $ run_ checkStage game -prop_checkVillagesTurnAdvancesToSeersTurn :: Game -> Property-prop_checkVillagesTurnAdvancesToSeersTurn game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    not (null . filterAlive . filterSeers $ run_ checkStage game'' ^. players)-    ==> isSeersTurn $ run_ checkStage game''-    where-        game'   = game { _stage = VillagesTurn }-        n       = length $ game' ^. players+prop_checkVillagesTurnAdvancesToSeersTurn :: GameWithLynchVotes -> Property+prop_checkVillagesTurnAdvancesToSeersTurn (GameWithLynchVotes game) =+    any isSeer (filterAlive $ run_ checkStage game ^. players)+    ==> isSeersTurn $ run_ checkStage game -prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: Game -> Property-prop_checkVillagesTurnLynchesOnePlayerWhenConsensus game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> length (filterDead $ run_ checkStage game'' ^. players) == 1-    where-        game'   = game { _stage = VillagesTurn }-        n       = length $ game' ^. players+prop_checkVillagesTurnLynchesOnePlayerWhenConsensus :: GameWithLynchVotes -> Property+prop_checkVillagesTurnLynchesOnePlayerWhenConsensus (GameWithLynchVotes game) =+    length (getVoteResult game) == 1+    ==> length (filterDead $ run_ checkStage game ^. players) == 1 +-- TODO (hjw) prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats :: Game -> Property prop_checkVillagesTurnLynchesNoOneWhenConflictedAndNoScapegoats game =     forAll (runArbitraryCommands n game') $ \game'' ->     length (getVoteResult game'') > 1     ==> length (filterDead $ run_ checkStage game'' ^. players) == length (filterDead $ game' ^. players)     where-        game'   = (foldl killPlayer game (filterScapegoats $ game ^. players)) { _stage = VillagesTurn }-        n       = length $ game' ^. players--prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: Game -> Property-prop_checkVillagesTurnLynchesScapegoatWhenConflicted game =-    forAll (runArbitraryCommands n game') $ \game'' -> and [-        length (getVoteResult game'') > 1,-        any isScapegoat $ game' ^. players-        ] ==> isScapegoat $ head (filterDead $ run_ checkStage game'' ^. players)-    where-        game'   = game { _stage = VillagesTurn }+        game'   = foldl killPlayer game (filterScapegoats $ game ^. players) & stage .~ VillagesTurn         n       = length $ game' ^. players -prop_checkVillagesTurnResetsVotes :: Game -> Property-prop_checkVillagesTurnResetsVotes game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    Map.null $ run_ checkStage game'' ^. votes-    where-        game'   = game { _stage = VillagesTurn }-        n       = length $ game' ^. players+prop_checkVillagesTurnLynchesScapegoatWhenConflicted :: GameWithLynchVotes -> Property+prop_checkVillagesTurnLynchesScapegoatWhenConflicted (GameWithLynchVotes game) =+    length (getVoteResult game) > 1+    ==> isScapegoat $ head (filterDead $ run_ checkStage game ^. players) -prop_checkVillagesTurnDoesNothingUnlessAllVoted :: Game -> Property-prop_checkVillagesTurnDoesNothingUnlessAllVoted game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    isVillagesTurn $ run_ checkStage game''-    where-        game'   = game { _stage = VillagesTurn }-        n       = length (game' ^. players) - 1+prop_checkVillagesTurnResetsVotes :: GameWithLynchVotes -> Bool+prop_checkVillagesTurnResetsVotes (GameWithLynchVotes game) =+    Map.null $ run_ checkStage game ^. votes -prop_checkWerewolvesTurnAdvancesToWitchsTurn :: Game -> Property-prop_checkWerewolvesTurnAdvancesToWitchsTurn game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> let target = head $ getVoteResult game''-        in not (isWitch target)-        ==> isWitchsTurn $ run_ checkStage game''+prop_checkVillagesTurnDoesNothingUnlessAllVoted :: GameAtVillagesTurn -> Property+prop_checkVillagesTurnDoesNothingUnlessAllVoted (GameAtVillagesTurn game) =+    forAll (runArbitraryCommands n game) $ \game' ->+    isVillagesTurn $ run_ checkStage game'     where-        game'   = game { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+        n = length (game ^. players) - 1 -prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured :: Game -> Property-prop_checkWerewolvesTurnDoesntSkipWitchsTurnWhenWitchDevoured game =-    forAll (arbitraryWitch game) $ \witch ->-    let devourVoteCommands = map (\werewolf -> devourVoteCommand (werewolf ^. name) (witch ^. name)) (filterWerewolves $ game ^. players)-        game'' = foldl (flip $ run_ . apply) game' devourVoteCommands-    in isWitchsTurn $ run_ checkStage game''-    where-        game' = game { _stage = WerewolvesTurn }+prop_checkWerewolvesTurnAdvancesToWitchsTurn :: GameWithDevourVotes -> Property+prop_checkWerewolvesTurnAdvancesToWitchsTurn (GameWithDevourVotes game) =+    length (getVoteResult game) == 1+    ==> isWitchsTurn $ run_ checkStage game -prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned :: Game -> Bool-prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned game =+prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned :: GameWithDevourVotes -> Bool+prop_checkWerewolvesTurnSkipsWitchsTurnWhenHealedAndPoisoned (GameWithDevourVotes game) =     not . isWitchsTurn $ run_ checkStage game'     where-        game' = game { _stage = WerewolvesTurn, _healUsed = True, _poisonUsed = True }--prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus :: Game -> Property-prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> length (filterDead . filter (not . isWitch) $ run_ checkStage game'' ^. players) == 1-    where-        game'   = (foldl killPlayer game (filterWitches $ game ^. players)) { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players--prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: Gen Bool-prop_checkWerewolvesTurnKillsNoOneWhenConflicted = do-    game <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) > 1--    return . isNothing . getDevourEvent $ run_ checkStage game+        game' = game & healUsed .~ True & poisonUsed .~ True -prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended :: Gen Bool-prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended = do-    game        <- suchThat arbitraryGameWithDevourVotes $ \game -> length (getVoteResult game) == 1-    let game'   = game { _protect = Just $ head (getVoteResult game) ^. name }+prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus :: GameWithDevourVotes -> Property+prop_checkWerewolvesTurnKillsOnePlayerWhenConsensus (GameWithDevourVotes game) =+    length (getVoteResult game) == 1+    ==> isJust . getDevourEvent $ run_ checkStage game -    return . isNothing . getDevourEvent $ run_ checkStage game'+prop_checkWerewolvesTurnKillsNoOneWhenConflicted :: GameWithDevourVotes -> Property+prop_checkWerewolvesTurnKillsNoOneWhenConflicted (GameWithDevourVotes game) =+    length (getVoteResult game) > 1+    ==> isNothing . getDevourEvent $ run_ checkStage game -prop_checkWerewolvesTurnResetsProtect :: Gen Bool-prop_checkWerewolvesTurnResetsProtect = do-    game <- arbitraryGameWithProtectAndDevourVotes+prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended :: GameWithProtectAndDevourVotes -> Property+prop_checkWerewolvesTurnKillsNoOneWhenTargetDefended (GameWithProtectAndDevourVotes game) =+    length (getVoteResult game) == 1+    ==> isNothing . getDevourEvent $ run_ checkStage game'+    where+        target  = head $ getVoteResult game+        game'   = game & protect .~ Just (target ^. name) -    return . isNothing $ run_ checkStage game ^. protect+prop_checkWerewolvesTurnResetsProtect :: GameWithProtectAndDevourVotes -> Bool+prop_checkWerewolvesTurnResetsProtect (GameWithProtectAndDevourVotes game) =+    isNothing $ run_ checkStage game ^. protect -prop_checkWerewolvesTurnResetsVotes :: Game -> Property-prop_checkWerewolvesTurnResetsVotes game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    Map.null $ run_ checkStage game'' ^. votes-    where-        game'   = game { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+prop_checkWerewolvesTurnResetsVotes :: GameWithDevourVotes -> Bool+prop_checkWerewolvesTurnResetsVotes (GameWithDevourVotes game) =+    Map.null $ run_ checkStage game ^. votes -prop_checkWerewolvesTurnDoesNothingUnlessAllVoted :: Game -> Property-prop_checkWerewolvesTurnDoesNothingUnlessAllVoted game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    isWerewolvesTurn $ run_ checkStage game''+prop_checkWerewolvesTurnDoesNothingUnlessAllVoted :: GameAtWerewolvesTurn -> Property+prop_checkWerewolvesTurnDoesNothingUnlessAllVoted (GameAtWerewolvesTurn game) =+    forAll (runArbitraryCommands n game) $ \game' ->+    isWerewolvesTurn $ run_ checkStage game'     where-        game'   = game { _stage = WerewolvesTurn }-        n       = length (filterWerewolves $ game' ^. players) - 1+        n = length (filterWerewolves $ game ^. players) - 1 -prop_checkWitchsTurnAdvancesToVillagesTurn :: Game -> Property-prop_checkWitchsTurnAdvancesToVillagesTurn game =-    forAll (arbitraryPassCommand game') $ \command ->-    isVillagesTurn $ run_ (apply command >> checkStage) game'-    where-        game' = game { _stage = WitchsTurn }+prop_checkWitchsTurnAdvancesToVillagesTurn :: GameAtWitchsTurn -> Property+prop_checkWitchsTurnAdvancesToVillagesTurn (GameAtWitchsTurn game) =+    forAll (arbitraryPassCommand game) $ \(Blind command) ->+    isVillagesTurn $ run_ (apply command >> checkStage) game +-- TODO (hjw) prop_checkWitchsTurnHealsDevoureeWhenHealed :: Game -> Property prop_checkWitchsTurnHealsDevoureeWhenHealed game =     forAll (runArbitraryCommands n game') $ \game'' ->@@ -270,69 +209,51 @@     ==> let target = head $ getVoteResult game''         in not (isWitch target)         ==> let game''' = run_ checkStage game''-            in forAll (arbitraryHealCommand game''') $ \command ->-            forAll (arbitraryPassCommand game''') $ \passCommand ->+            in forAll (arbitraryHealCommand game''') $ \(Blind command) ->+            forAll (arbitraryPassCommand game''') $ \(Blind passCommand) ->             null . filterDead $ run_ checkStage                 (run_ (apply passCommand) $                     run_ (apply command) game'''                     ) ^. players     where-        game'   = game { _stage = WerewolvesTurn }+        game'   = game & stage .~ WerewolvesTurn         n       = length . filterWerewolves $ game' ^. players -prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: Game -> Property-prop_checkWitchsTurnKillsOnePlayerWhenPoisoned game =-    forAll (arbitraryPoisonCommand game') $ \command ->-    forAll (arbitraryPassCommand game') $ \passCommand ->-    length (filterDead $ run_ (apply command >> apply passCommand >> checkStage) game' ^. players) == 1-    where-        game' = game { _stage = WitchsTurn }--prop_checkWitchsTurnDoesNothingWhenPassed :: Game -> Property-prop_checkWitchsTurnDoesNothingWhenPassed game =-    forAll (arbitraryPassCommand game') $ \command ->-    null . filterDead $ run_ (apply command >> checkStage) game' ^. players-    where-        game' = game { _stage = WitchsTurn }+prop_checkWitchsTurnKillsOnePlayerWhenPoisoned :: GameWithPoison -> Property+prop_checkWitchsTurnKillsOnePlayerWhenPoisoned (GameWithPoison game) =+    forAll (arbitraryPassCommand game) $ \(Blind command) ->+    length (filterDead $ run_ (apply command >> checkStage) game ^. players) == 1 -prop_checkWitchsTurnResetsHeal :: Game -> Property-prop_checkWitchsTurnResetsHeal game =-    forAll (runArbitraryCommands n game') $ \game'' ->-    length (getVoteResult game'') == 1-    ==> let target = head $ getVoteResult game''-        in not (isWitch target)-        ==> let game''' = run_ checkStage game''-            in forAll (arbitraryHealCommand game''') $ \command ->-            forAll (arbitraryPassCommand game''') $ \passCommand ->-            not $ run_ checkStage-                (run_ (apply passCommand) $-                    run_ (apply command) game'''-                    ) ^. heal-    where-        game'   = game { _stage = WerewolvesTurn }-        n       = length . filterWerewolves $ game' ^. players+prop_checkWitchsTurnDoesNothingWhenPassed :: GameAtWitchsTurn -> Property+prop_checkWitchsTurnDoesNothingWhenPassed (GameAtWitchsTurn game) =+    forAll (arbitraryPassCommand game) $ \(Blind command) ->+    null . filterDead $ run_ (apply command >> checkStage) game ^. players +prop_checkWitchsTurnResetsHeal :: GameWithHeal -> Property+prop_checkWitchsTurnResetsHeal (GameWithHeal game) =+    forAll (arbitraryPassCommand game) $ \(Blind command) ->+    not $ run_ (apply command >> checkStage) game ^. heal -prop_checkWitchsTurnResetsPoison :: Game -> Property-prop_checkWitchsTurnResetsPoison game =-    forAll (arbitraryPoisonCommand game') $ \command ->-    isNothing $ run_ (apply command >> checkStage) game' ^. poison-    where-        game' = game { _stage = WitchsTurn }+prop_checkWitchsTurnResetsPoison :: GameWithPoison -> Property+prop_checkWitchsTurnResetsPoison (GameWithPoison game) =+    forAll (arbitraryPassCommand game) $ \(Blind command) ->+    isNothing $ run_ (apply command >> checkStage) game ^. poison +-- TODO (hjw) prop_checkGameOverAdvancesStage :: Game -> Property prop_checkGameOverAdvancesStage game =     forAll (sublistOf $ game ^. players) $ \players' ->     let game' = foldl killPlayer game players' in-        length (nub . map (_allegiance . _role) . filterAlive $ game' ^. players) <= 1+        length (nub . map (view $ role . allegiance) . filterAlive $ game' ^. players) <= 1         ==> isGameOver $ run_ checkGameOver game' +-- TODO (hjw) prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive :: Game -> Property prop_checkGameOverDoesNothingWhenAtLeastTwoAllegiancesAlive game =     not (isGameOver game)     ==> forAll (sublistOf $ game ^. players) $ \players' ->         let game' = foldl killPlayer game players' in-            length (nub . map (_allegiance . _role) . filterAlive $ game' ^. players) > 1+            length (nub . map (view $ role . allegiance) . filterAlive $ game' ^. players) > 1             ==> not . isGameOver $ run_ checkGameOver game'  prop_startGameStartsWithSunsetStage :: Property@@ -347,65 +268,81 @@  prop_startGameErrorsUnlessUniquePlayerNames :: Game -> Property prop_startGameErrorsUnlessUniquePlayerNames game =-    forAll (elements players') $ \player -> isLeft (runExcept . runWriterT $ startGame "" (player:players'))+    forAll (elements players') $ \player ->+    isLeft (runExcept . runWriterT $ startGame "" (player:players'))     where         players' = game ^. players  prop_startGameErrorsWhenLessThan7Players :: [Player] -> Property prop_startGameErrorsWhenLessThan7Players players =     length players < 7-    ==> isLeft (runExcept . runWriterT $ startGame "" players)+    ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_startGameErrorsWhenMoreThan24Players :: Property prop_startGameErrorsWhenMoreThan24Players =     forAll (resize 30 $ listOf arbitrary) $ \players ->         length players > 24-        ==> isLeft (runExcept . runWriterT $ startGame "" players)+        ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_startGameErrorsWhenMoreThan1Defender :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Defender players =     length (filterDefenders players) > 1-    ==> isLeft (runExcept . runWriterT $ startGame "" players)+    ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_startGameErrorsWhenMoreThan1Scapegoat :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Scapegoat players =     length (filterScapegoats players) > 1-    ==> isLeft (runExcept . runWriterT $ startGame "" players)+    ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_startGameErrorsWhenMoreThan1Seer :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Seer players =     length (filterSeers players) > 1-    ==> isLeft (runExcept . runWriterT $ startGame "" players)+    ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_startGameErrorsWhenMoreThan1VillagerVillager :: [Player] -> Property prop_startGameErrorsWhenMoreThan1VillagerVillager players =     length (filterVillagerVillagers players) > 1-    ==> isLeft (runExcept . runWriterT $ startGame "" players)+    ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_startGameErrorsWhenMoreThan1Witch :: [Player] -> Property prop_startGameErrorsWhenMoreThan1Witch players =     length (filterWitches players) > 1-    ==> isLeft (runExcept . runWriterT $ startGame "" players)+    ==> isLeft . runExcept . runWriterT $ startGame "" players  prop_createPlayersUsesGivenPlayerNames :: [Text] -> [Role] -> Property-prop_createPlayersUsesGivenPlayerNames playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . (playerNames ==) . map _name+prop_createPlayersUsesGivenPlayerNames playerNames extraRoles = monadicIO $ do+    players <- createPlayers playerNames extraRoles +    return $ playerNames == map (view name) players+ prop_createPlayersUsesGivenRoles :: [Text] -> [Role] -> Property-prop_createPlayersUsesGivenRoles playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . isSubsequenceOf extraRoles . map _role+prop_createPlayersUsesGivenRoles playerNames extraRoles = monadicIO $ do+    players <- createPlayers playerNames extraRoles +    return $ extraRoles `isSubsequenceOf` map (view role) players+ prop_createPlayersCreatesAlivePlayers :: [Text] -> [Role] -> Property-prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ createPlayers playerNames extraRoles >>= return . all ((Alive ==) . _state)+prop_createPlayersCreatesAlivePlayers playerNames extraRoles = monadicIO $ do+    players <- createPlayers playerNames extraRoles +    return $ all isAlive players+ prop_randomiseRolesReturnsNRoles :: [Role] -> Int -> Property-prop_randomiseRolesReturnsNRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . (==) n . length+prop_randomiseRolesReturnsNRoles extraRoles n = monadicIO $ do+    roles <- randomiseRoles extraRoles n +    return $ length roles == n+ prop_randomiseRolesUsesGivenRoles :: [Role] -> Int -> Property-prop_randomiseRolesUsesGivenRoles extraRoles n = monadicIO $ randomiseRoles extraRoles n >>= return . isSubsequenceOf extraRoles+prop_randomiseRolesUsesGivenRoles extraRoles n = monadicIO $ do+    roles <- randomiseRoles extraRoles n +    return $ extraRoles `isSubsequenceOf` roles+ prop_randomiseRolesProportionsAllegiances :: [Role] -> Int -> Property prop_randomiseRolesProportionsAllegiances extraRoles n = monadicIO $ do     roles <- randomiseRoles extraRoles n -    let werewolvesCount = length . elemIndices Role.Werewolves $ map _allegiance roles+    let werewolvesCount = length . elemIndices Role.Werewolves $ map (view allegiance) roles -    return $ n `quot` 6 + 1 == werewolvesCount+    return $ werewolvesCount == n `quot` 6 + 1

@@ -1,5 +1,5 @@ name:           werewolf-version:        0.4.3.2+version:        0.4.4.0  author:         Henry J. Wylde maintainer:     public@hjwylde.com@@ -49,16 +49,16 @@     other-extensions:         OverloadedStrings     build-depends:-        aeson >= 0.8,+        aeson >= 0.8 && < 0.11,         base >= 4.8 && < 5,-        directory >= 1.2,-        extra >= 1.4,-        filepath >= 1.4,-        lens >= 4.12,-        mtl >= 2.2,-        optparse-applicative >= 0.11,-        text >= 1.2,-        transformers >= 0.4,+        directory == 1.2.*,+        extra == 1.4.*,+        filepath == 1.4.*,+        lens >= 4.12 && < 4.14,+        mtl == 2.2.*,+        optparse-applicative >= 0.11 && < 0.13,+        text == 1.2.*,+        transformers == 0.4.*,         werewolf  library@@ -81,18 +81,18 @@         RankNTypes,         TemplateHaskell     build-depends:-        aeson >= 0.8,+        aeson >= 0.8 && < 0.11,         base >= 4.8 && < 5,-        containers >= 0.5,-        directory >= 1.2,-        extra >= 1.4,-        filepath >= 1.4,-        lens >= 4.12,-        MonadRandom >= 0.4,-        mtl >= 2.2,+        containers == 0.5.*,+        directory == 1.2.*,+        extra == 1.4.*,+        filepath == 1.4.*,+        lens >= 4.12 && < 4.14,+        MonadRandom == 0.4.*,+        mtl == 2.2.*,         random-shuffle,-        text >= 1.2,-        transformers >= 0.4+        text == 1.2.*,+        transformers == 0.4.*  test-suite werewolf-test     type:           exitcode-stdio-1.0@@ -112,12 +112,12 @@         OverloadedStrings     build-depends:         base >= 4.8 && < 5,-        containers >= 0.5,-        extra >= 1.4,-        lens >= 4.12,-        mtl >= 2.2,-        QuickCheck >= 2.8,+        containers == 0.5.*,+        extra == 1.4.*,+        lens >= 4.12 && < 4.14,+        mtl == 2.2.*,+        QuickCheck == 2.8.*,         tasty >= 0.10 && < 0.12,-        tasty-quickcheck >= 0.8,-        text >= 1.2,+        tasty-quickcheck == 0.8.*,+        text == 1.2.*,         werewolf