Adapt code to new library change making player parametric in the key

src/Automaton.hs

@@ -5,7 +5,8 @@ module Automaton (
 
 import Control.Monad.Reader (asks, lift)
 import qualified Data (RW(..))
-import qualified Game (Game(..), T(..), new, play)
+import qualified Game (new, play)
+import qualified Hanafuda.KoiKoi as KoiKoi (Game(..))
 import qualified Session (Status(..), T(..), Update)
 import qualified Server (get, logIn, logOut, update, register)
 import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
@@ -61,10 +62,10 @@ 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 Game.state newGame of
+  case newGame of
-    Game.Error s -> status `withError` s
+    KoiKoi.Error s -> status `withError` s
-    Game.Over _ -> undefined
+    KoiKoi.Over _ -> undefined
-    Game.On _ -> do
+    KoiKoi.On _ -> do
       App.update_ $ Server.update gameKey (const newGame)
       Message.notifyPlayers newGame
       return status

src/Game.hs

@@ -5,25 +5,23 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Game (
-      Hanafuda.KoiKoi.Game(..)
+      Key
-    , Key
     , View
-    , T(..)
+    , T
     , export
     , new
     , play
   ) where
 
 import Data.Text (pack)
-import Data.Map (Map, (!), fromList, mapWithKey)
+import Data.Map (mapWithKey)
 import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
 import Data.Aeson.Types (toJSONKeyText)
-import qualified JSON (defaultOptions, distinct, singleLCField)
+import qualified JSON (defaultOptions, singleLCField)
-import qualified Data (Key, RW(..))
+import qualified Data (Key)
 import qualified Player (Key)
 import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
-import qualified Hanafuda.Player (Player(..), Seat(..))
+import qualified Hanafuda.Player (Player(..), Players(..))
-import qualified Hanafuda.KoiKoi.Game (remap)
 import qualified Hanafuda.KoiKoi (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play)
 import GHC.Generics
 
@@ -33,7 +31,8 @@ deriving instance Generic Hanafuda.KoiKoi.Mode
 deriving instance Generic Hanafuda.KoiKoi.Move
 deriving instance Generic Hanafuda.KoiKoi.Yaku
 deriving instance Generic Hanafuda.KoiKoi.Step
-deriving instance Generic1 Hanafuda.Player.Player
+deriving instance Generic1 (Hanafuda.Player.Player Player.Key)
+deriving instance Generic1 (Hanafuda.Player.Players Player.Key)
 
 type On = Hanafuda.KoiKoi.On Player.Key
 type Over = Hanafuda.KoiKoi.Over Player.Key
@@ -59,10 +58,10 @@ instance FromJSON Hanafuda.KoiKoi.Move where
 instance ToJSON Hanafuda.KoiKoi.Move where
   toEncoding = genericToEncoding JSON.singleLCField
 
-instance ToJSON1 Hanafuda.Player.Player where
+instance ToJSON1 (Hanafuda.Player.Player Player.Key) where
   liftToEncoding = genericLiftToEncoding JSON.defaultOptions
 
-instance ToJSON (Hanafuda.Player.Player Hanafuda.KoiKoi.Score) where
+instance ToJSON (Hanafuda.Player.Player Player.Key Hanafuda.KoiKoi.Score) where
   toJSON = toJSON1
   toEncoding = toEncoding1
 
@@ -74,49 +73,43 @@ instance ToJSONKey Hanafuda.KoiKoi.Yaku where
 instance ToJSON Hanafuda.KoiKoi.Step where
   toEncoding = genericToEncoding JSON.defaultOptions
 
+instance ToJSON1 (Hanafuda.Player.Players Player.Key) where
+  liftToEncoding = genericLiftToEncoding JSON.defaultOptions
+
+instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where
+  toJSON = toJSON1
+  toEncoding = toEncoding1
+
 instance ToJSON On
 instance ToJSON Over
 
-instance ToJSON View where
+type T = Hanafuda.KoiKoi.Game Player.Key
-  toEncoding = genericToEncoding JSON.distinct
 
-data T = T {
+instance ToJSON T
-      keys :: Map Hanafuda.Player.Seat Player.Key
-    , state :: Hanafuda.KoiKoi.Game Hanafuda.Player.Seat
-  }
 
 type Key = Data.Key T
 
-instance Data.RW (Hanafuda.KoiKoi.Game Hanafuda.Player.Seat) T where
-  get = state
-  set state game = game {state}
-
 new :: Player.Key -> Player.Key -> IO T
 new p1 p2 = do
-  on <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
+  on <- Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear
-  return $ T {
+  return $ Hanafuda.KoiKoi.On on
-      keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
-    , state = Hanafuda.KoiKoi.On on
-  }
 
-export :: Player.Key -> T -> View
+export :: Player.Key -> T -> T
-export key (T {keys, state}) =
+export key (Hanafuda.KoiKoi.On on) = Hanafuda.KoiKoi.On $ on {
-  case Hanafuda.KoiKoi.Game.remap (keys !) state of
+      Hanafuda.KoiKoi.deck = []
-    view@(Hanafuda.KoiKoi.Error _) -> view
+    , Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
-    view@(Hanafuda.KoiKoi.Over _) -> view
+  }
-    (Hanafuda.KoiKoi.On on) -> Hanafuda.KoiKoi.On $ on {
-        Hanafuda.KoiKoi.stock = []
-      , Hanafuda.KoiKoi.players = mapWithKey maskOpponentsHand $ Hanafuda.KoiKoi.players on
-    }
   where
+    Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
     maskOpponentsHand k player
       | k == key = player
       | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
+export _ game = game
 
 play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO T
-play key move game@(T {keys, state = Hanafuda.KoiKoi.On on})
+play key move (Hanafuda.KoiKoi.On on)
-  | keys ! Hanafuda.KoiKoi.playing on == key = do
+  | Hanafuda.KoiKoi.playing on == key = do
     newState <- Hanafuda.KoiKoi.play move on
-    return $ game {state = newState}
+    return $ newState
-  | otherwise = return $ game {state = Hanafuda.KoiKoi.Error "Not your turn"}
+  | otherwise = return $ Hanafuda.KoiKoi.Error "Not your turn"
-play _ _ game = return $ game {state = Hanafuda.KoiKoi.Error "This game is over"}
+play _ _ _ = return $ Hanafuda.KoiKoi.Error "This game is over"

src/Message.hs

@@ -16,18 +16,18 @@ module Message (
 
 import Data.List (intercalate)
 import Data.Foldable (forM_)
-import Data.Map (elems, keys)
+import Data.Map (keys)
 import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
 import Network.WebSockets (receiveData, sendTextData)
 import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Text (Text)
 import Control.Monad.Reader (asks, lift)
 import qualified Player (Key)
-import qualified Game (T(..), View, export)
+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 (Move(..))
+import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), On(..), Over(..), 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 :: Game.View}
+  | Game {game :: Game.T}
   | Pong
   | Error {error :: String}
   deriving (Generic)
@@ -100,7 +100,9 @@ update = Update {alone = [], paired = []}
 
 notifyPlayers :: Game.T -> App.T ()
 notifyPlayers game =
-  forM_ playerKeys $ \k ->
+  forM_ (keys $ scores game) $ \k ->
     sendTo [k] $ Game {game = Game.export k game}
   where
-    playerKeys = elems $ Game.keys game
+    scores (KoiKoi.On on) = KoiKoi.scores on
+    scores (KoiKoi.Over over) = KoiKoi.finalScores over
+    scores _ = mempty

src/Server.hs

@@ -24,7 +24,7 @@ import Data.Set (Set, member)
 import qualified Data.Set as Set (delete, empty, insert)
 import Data.Text (Text)
 import qualified Data (RW(..))
-import qualified Game (Key, T(..))
+import qualified Game (Key, T)
 import qualified Player (Key, T(..))
 import qualified Session (Status(..), T(..), Update)