From 1ace122876234c9a97325d1e98e679245c177c58 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Tue, 8 Jan 2019 22:48:18 +0100 Subject: [PATCH] Use latest changes in the lib to send a log of what happened during a turn --- hanafuda-webapp.cabal | 2 +- src/Automaton.hs | 22 +++++++++++++--------- src/Game.hs | 25 ++++++++++++++++--------- src/Message.hs | 10 +++++----- 4 files changed, 35 insertions(+), 24 deletions(-) diff --git a/hanafuda-webapp.cabal b/hanafuda-webapp.cabal index 5044104..59a838b 100644 --- a/hanafuda-webapp.cabal +++ b/hanafuda-webapp.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hanafuda-webapp -version: 0.2.0.1 +version: 0.2.1.0 synopsis: A webapp for the Haskell hanafuda library -- description: homepage: https://framagit.org/hanafuda diff --git a/src/Automaton.hs b/src/Automaton.hs index b9327f3..85c7404 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -3,7 +3,9 @@ module Automaton ( start ) where +import Control.Monad.Except (runExceptT) import Control.Monad.Reader (asks, lift) +import Control.Monad.Writer (runWriterT) import qualified Data (RW(..)) import qualified Game (new, play) import qualified Hanafuda.KoiKoi as KoiKoi (Game(..)) @@ -49,7 +51,7 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do then do gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update game <- Server.get gameKey <$> App.server - Message.notifyPlayers game Nothing + Message.notifyPlayers game [] return $ Session.Playing gameKey else do Message.broadcast $ Message.update {Message.alone = [key, to]} @@ -61,14 +63,16 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do key <- asks App.key game <- Server.get gameKey <$> App.server - newGame <- lift $ Game.play key move game - case newGame of - KoiKoi.Error s -> status `withError` s - KoiKoi.Over _ -> undefined - KoiKoi.On on -> do - App.update_ $ Server.update gameKey (const on) - Message.notifyPlayers on $ Just move - return status + (result, logs) <- lift . runWriterT . runExceptT $ Game.play key move game + case result of + Left message -> status `withError` message + Right newGame -> + case newGame of + KoiKoi.Over _ -> undefined + KoiKoi.On on -> do + App.update_ $ Server.update gameKey (const on) + Message.notifyPlayers on logs + return status edges state _ = state `withError` ("Invalid message in state " ++ show state) diff --git a/src/Game.hs b/src/Game.hs index d879f7d..2678d59 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -2,6 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,6 +15,7 @@ module Game ( , play ) where +import Control.Monad.Except (throwError) import Data.Text (pack) import Data.Map (mapWithKey) import Data.HashMap.Strict (insert) @@ -24,14 +26,16 @@ import qualified Data (Key) import qualified Player (Key) import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty) import qualified Hanafuda.Player (Player(..), Players(..)) -import qualified Hanafuda.KoiKoi (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play) +import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), On(..), Over(..), Score, Source(..), Step(..), Yaku(..), new, play) import GHC.Generics deriving instance Generic Hanafuda.Card deriving instance Generic Hanafuda.Flower +deriving instance Generic Hanafuda.KoiKoi.Action deriving instance Generic Hanafuda.KoiKoi.Mode deriving instance Generic Hanafuda.KoiKoi.Move deriving instance Generic Hanafuda.KoiKoi.Yaku +deriving instance Generic Hanafuda.KoiKoi.Source deriving instance Generic Hanafuda.KoiKoi.Step deriving instance Generic1 (Hanafuda.Player.Player Player.Key) deriving instance Generic1 (Hanafuda.Player.Players Player.Key) @@ -53,6 +57,8 @@ instance ToJSON Hanafuda.Pack where toJSON = toJSON . Hanafuda.cardsOfPack toEncoding = toEncoding . Hanafuda.cardsOfPack +instance ToJSON Hanafuda.KoiKoi.Action + instance ToJSON Hanafuda.KoiKoi.Mode instance FromJSON Hanafuda.KoiKoi.Move where @@ -60,6 +66,11 @@ instance FromJSON Hanafuda.KoiKoi.Move where instance ToJSON Hanafuda.KoiKoi.Move where toEncoding = genericToEncoding JSON.singleLCField +instance ToJSON Hanafuda.KoiKoi.Source + +instance ToJSON Hanafuda.KoiKoi.Step where + toEncoding = genericToEncoding JSON.defaultOptions + instance ToJSON1 (Hanafuda.Player.Player Player.Key) where liftToEncoding = genericLiftToEncoding JSON.defaultOptions @@ -72,9 +83,6 @@ instance ToJSON Hanafuda.KoiKoi.Yaku where instance ToJSONKey Hanafuda.KoiKoi.Yaku where toJSONKey = toJSONKeyText (pack . show) -instance ToJSON Hanafuda.KoiKoi.Step where - toEncoding = genericToEncoding JSON.defaultOptions - instance ToJSON1 (Hanafuda.Player.Players Player.Key) where liftToEncoding = genericLiftToEncoding JSON.defaultOptions @@ -103,9 +111,8 @@ export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck o Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered } -play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO (Hanafuda.KoiKoi.Game Player.Key) +play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key) play key move on - | Hanafuda.KoiKoi.playing on == key = do - newState <- Hanafuda.KoiKoi.play move on - return $ newState - | otherwise = return $ Hanafuda.KoiKoi.Error "Not your turn" + | Hanafuda.KoiKoi.playing on == key = + Hanafuda.KoiKoi.play move on + | otherwise = throwError "Not your turn" diff --git a/src/Message.hs b/src/Message.hs index e6573f5..12e1f05 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -27,7 +27,7 @@ import qualified Game (T, export) import qualified Session (T(..)) import qualified Server (T(..), get) import qualified App (Context(..), T, connection, debug, server) -import qualified Hanafuda.KoiKoi as KoiKoi (On(..), Move(..)) +import qualified Hanafuda.KoiKoi as KoiKoi (Action, On(..), Move(..)) import GHC.Generics (Generic) data FromClient = @@ -48,7 +48,7 @@ data T = Relay {from :: Player.Key, message :: FromClient} | Welcome {room :: Server.T, key :: Player.Key} | Update {alone :: [Player.Key], paired :: [Player.Key]} - | Game {game :: Value, played :: Maybe KoiKoi.Move} + | Game {game :: Value, logs :: [KoiKoi.Action]} | Pong | Error {error :: String} deriving (Generic) @@ -98,7 +98,7 @@ get = update :: T update = Update {alone = [], paired = []} -notifyPlayers :: Game.T -> Maybe KoiKoi.Move -> App.T () -notifyPlayers game played = +notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T () +notifyPlayers game logs = forM_ (keys $ KoiKoi.scores game) $ \k -> - sendTo [k] $ Game {game = Game.export k game, played} + sendTo [k] $ Game {game = Game.export k game, logs}