Rename and implement correctly the type used to show a partial state of the game to players

src/Automaton.hs

@@ -3,6 +3,7 @@ module Automaton (
     start
   ) where
 
+import Data.Foldable (forM_)
 import Control.Monad.Reader (asks, lift)
 import qualified Game (export, new)
 import qualified Session (Status(..), T(..))
@@ -48,7 +49,8 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
             gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
             game <- Server.get gameKey <$> App.server
             current <- App.current
-            Message.sendTo [(to, session), (key, current)] $ Message.NewGame $ Game.export game
+            forM_ [(to, session), (key, current)] $ \(k, s) ->
+              Message.sendTo [(k, s)] $ Message.NewGame $ Game.export k game
             return $ Session.Playing gameKey
           else do
             Message.broadcast $ Message.update {Message.alone = [key, to]}

src/Game.hs

@@ -1,62 +1,114 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Game (
       Key
-    , State(..)
+    , View(..)
     , T(..)
     , export
     , new
   ) where
 
-import Data.Map (Map, (!), fromList, mapKeys)
-import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding)
-import qualified JSON (singleLCField)
+import Data.Text (pack)
+import Data.Map (Map, (!), fromList, mapKeys, mapWithKey)
+import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
+import Data.Aeson.Types (toJSONKeyText)
+import qualified JSON (defaultOptions, singleLCField)
 import qualified Data (Key)
 import qualified Player (Key)
-import qualified Hanafuda (Card(..), cardsOfPack)
-import qualified Hanafuda.Player (Player(..), Seat(..))
-import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), new)
+import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
+import qualified Hanafuda.Player (Player(..), Seat(..), Points)
+import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), Score, Step(..), Yaku(..), new)
 import GHC.Generics
 
 deriving instance Generic Hanafuda.Card
+deriving instance Generic Hanafuda.Flower
+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
 
 instance FromJSON Hanafuda.Card
 instance ToJSON Hanafuda.Card
 
+instance ToJSON Hanafuda.Flower
+
+instance ToJSON Hanafuda.Pack where
+  toJSON = toJSON . Hanafuda.cardsOfPack
+  toEncoding = toEncoding . Hanafuda.cardsOfPack
+
+instance ToJSON Hanafuda.KoiKoi.Mode
+
 instance FromJSON Hanafuda.KoiKoi.Move
 instance ToJSON Hanafuda.KoiKoi.Move where
   toEncoding = genericToEncoding JSON.singleLCField
 
+instance ToJSON1 Hanafuda.Player.Player where
+  liftToEncoding = genericLiftToEncoding JSON.defaultOptions
+
+instance ToJSON (Hanafuda.Player.Player Hanafuda.KoiKoi.Score) where
+  toJSON = toJSON1
+  toEncoding = toEncoding1
+
+instance ToJSON Hanafuda.KoiKoi.Yaku where
+  toEncoding = genericToEncoding JSON.defaultOptions
+instance ToJSONKey Hanafuda.KoiKoi.Yaku where
+  toJSONKey = toJSONKeyText (pack . show)
+
+instance ToJSON Hanafuda.KoiKoi.Step where
+  toEncoding = genericToEncoding JSON.defaultOptions
+
 data T = T {
-      seats :: Map Hanafuda.Player.Seat Player.Key
+      keys :: Map Hanafuda.Player.Seat Player.Key
+    , seats :: Map Player.Key Hanafuda.Player.Seat
     , state :: Hanafuda.KoiKoi.On
   }
-type Key = Data.Key T
 
-data State = State {
-      river :: [Hanafuda.Card]
-    , yakus :: Map Player.Key [Hanafuda.Card]
+type Key = Data.Key T
+type Players a = Map Player.Key a
+
+data View = View {
+      mode :: Hanafuda.KoiKoi.Mode
+    , scores :: Players Hanafuda.Player.Points
+    , month :: Hanafuda.Flower
+    , players :: Players (Hanafuda.Player.Player Hanafuda.KoiKoi.Score)
+    , playing :: Player.Key
+    , winning :: Player.Key
+    , oyake :: Player.Key
+    , river :: [Hanafuda.Card]
+    , step :: Hanafuda.KoiKoi.Step
+    , trick :: [Hanafuda.Card]
   } deriving (Generic)
 
-instance ToJSON State where
+instance ToJSON View where
   toEncoding = genericToEncoding JSON.singleLCField
 
 new :: Player.Key -> Player.Key -> IO T
 new p1 p2 = do
   state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
   return $ T {
-      seats = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
+      keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
+    , seats = fromList [(p1, Hanafuda.Player.Player1), (p2, Hanafuda.Player.Player2)]
     , state
   }
 
-export :: T -> State
-export (T {seats, state}) = State {
-      river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
-    , yakus = fmap extractYakus players
+export :: Player.Key -> T -> View
+export key (T {keys, state}) = View {
+      mode = Hanafuda.KoiKoi.mode state
+    , scores = reindex $ Hanafuda.KoiKoi.scores state
+    , month = Hanafuda.KoiKoi.month state
+    , players = mapWithKey (\k -> if k == key then id else maskHand) players
+    , playing = keys ! Hanafuda.KoiKoi.playing state
+    , winning = keys ! Hanafuda.KoiKoi.winning state
+    , oyake = keys ! Hanafuda.KoiKoi.oyake state
+    , river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
+    , step = Hanafuda.KoiKoi.step state
+    , trick = Hanafuda.KoiKoi.trick state
   }
   where
-    extractYakus = Hanafuda.cardsOfPack . Hanafuda.Player.meld
-    players = mapKeys (seats !) $ Hanafuda.KoiKoi.players state
+    reindex = mapKeys (keys !)
+    players = reindex $ Hanafuda.KoiKoi.players state
+    maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty}

src/Message.hs

@@ -21,7 +21,7 @@ import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Text (Text)
 import Control.Monad.Reader (asks, lift)
 import qualified Player (Key)
-import qualified Game (State)
+import qualified Game (View)
 import qualified Session (T(..))
 import qualified Server (T(..))
 import qualified App (Context(..), T, connection, current, debug, server)
@@ -46,7 +46,7 @@ data T =
     Relay {from :: Player.Key, message :: FromClient}
   | Welcome {room :: Server.T, key :: Player.Key}
   | Update {alone :: [Player.Key], paired :: [Player.Key]}
-  | NewGame Game.State
+  | NewGame Game.View
   | Pong
   | Error {error :: String}
   deriving (Generic)