161 lines
4.9 KiB
Haskell
161 lines
4.9 KiB
Haskell
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Hanafuda.Message (
|
|
T(..)
|
|
, FromClient(..)
|
|
, PlayerStatus(..)
|
|
, PublicGame
|
|
, Room
|
|
) where
|
|
|
|
import Data.Char (toLower)
|
|
import Data.Aeson (
|
|
FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..)
|
|
, Value, (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
|
|
, genericToEncoding, object, pairs, withObject
|
|
)
|
|
import Data.Aeson.Types (toJSONKeyText)
|
|
import Data.Map (Map)
|
|
import Data.Monoid ((<>))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text (pack, unpack)
|
|
import GHC.Generics (Generic)
|
|
import qualified Hanafuda (Card(..), Flower(..), Pack, cardsOfPack, empty, packOfCards)
|
|
import Hanafuda.ID (ID(..), getID)
|
|
import Hanafuda.KoiKoi (PlayerID, GameBlueprint(..))
|
|
import qualified Hanafuda.KoiKoi as KoiKoi (
|
|
Action(..), Game(..), Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..)
|
|
)
|
|
import Hanafuda.Player (Player(..), Players(..))
|
|
|
|
deriving instance Generic PlayerID
|
|
instance FromJSON PlayerID
|
|
instance FromJSONKey PlayerID where
|
|
fromJSONKey = FromJSONKeyText (ID . read . Text.unpack)
|
|
instance ToJSON PlayerID where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
instance ToJSONKey PlayerID where
|
|
toJSONKey = toJSONKeyText (Text.pack . getID)
|
|
|
|
first :: (a -> a) -> [a] -> [a]
|
|
first _ [] = []
|
|
first f (x:xs) = f x:xs
|
|
|
|
singleLCField :: Options
|
|
singleLCField = defaultOptions {
|
|
constructorTagModifier = (toLower `first`)
|
|
, sumEncoding = ObjectWithSingleField
|
|
}
|
|
|
|
deriving instance Generic KoiKoi.Move
|
|
instance FromJSON KoiKoi.Move where
|
|
parseJSON = genericParseJSON singleLCField
|
|
instance ToJSON KoiKoi.Move where
|
|
toEncoding = genericToEncoding singleLCField
|
|
|
|
deriving instance Generic Hanafuda.Card
|
|
instance FromJSON Hanafuda.Card
|
|
instance ToJSON Hanafuda.Card where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
data FromClient =
|
|
Answer {accept :: Bool}
|
|
| Invitation {to :: PlayerID}
|
|
| LogIn {name :: Text}
|
|
| LogOut
|
|
| Play {move :: KoiKoi.Move}
|
|
| Quit
|
|
| Ping
|
|
deriving (Generic)
|
|
|
|
instance FromJSON FromClient
|
|
instance ToJSON FromClient where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
newtype PlayerStatus = PlayerStatus (Text, Bool) deriving (Generic, Show)
|
|
|
|
instance FromJSON PlayerStatus where
|
|
parseJSON = withObject "PlayerStatus" $ \v -> fmap PlayerStatus . (,)
|
|
<$> v .: "name"
|
|
<*> v .: "alone"
|
|
instance ToJSON PlayerStatus where
|
|
toJSON (PlayerStatus (name, alone)) =
|
|
object ["name" .= name, "alone" .= alone]
|
|
toEncoding (PlayerStatus (name, alone)) =
|
|
pairs ("name" .= name <> "alone" .= alone)
|
|
|
|
type Room = Map PlayerID PlayerStatus
|
|
|
|
deriving instance Generic KoiKoi.Source
|
|
instance FromJSON KoiKoi.Source
|
|
instance ToJSON KoiKoi.Source where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
deriving instance Generic KoiKoi.Action
|
|
instance FromJSON KoiKoi.Action
|
|
instance ToJSON KoiKoi.Action where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
deriving instance Generic KoiKoi.Yaku
|
|
instance FromJSON KoiKoi.Yaku
|
|
instance FromJSONKey KoiKoi.Yaku where
|
|
fromJSONKey = FromJSONKeyText (read . Text.unpack)
|
|
instance ToJSON KoiKoi.Yaku where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
instance ToJSONKey KoiKoi.Yaku where
|
|
toJSONKey = toJSONKeyText (Text.pack . show)
|
|
|
|
deriving instance Generic (Player KoiKoi.Score)
|
|
instance FromJSON (Player KoiKoi.Score)
|
|
instance ToJSON (Player KoiKoi.Score) where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
deriving instance Generic (Players KoiKoi.Score)
|
|
instance FromJSON (Players KoiKoi.Score)
|
|
instance ToJSON (Players KoiKoi.Score) where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
deriving instance Generic KoiKoi.Step
|
|
instance FromJSON KoiKoi.Step
|
|
instance ToJSON KoiKoi.Step where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
instance FromJSON Hanafuda.Pack where
|
|
parseJSON = fmap Hanafuda.packOfCards . parseJSON
|
|
instance ToJSON Hanafuda.Pack where
|
|
toJSON = toJSON . Hanafuda.cardsOfPack
|
|
toEncoding = toEncoding . Hanafuda.cardsOfPack
|
|
|
|
deriving instance Generic KoiKoi.Mode
|
|
instance FromJSON KoiKoi.Mode
|
|
instance ToJSON KoiKoi.Mode where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
deriving instance Generic Hanafuda.Flower
|
|
instance FromJSON Hanafuda.Flower
|
|
instance ToJSON Hanafuda.Flower where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
type PublicGame = GameBlueprint Int
|
|
|
|
deriving instance Generic PublicGame
|
|
instance FromJSON PublicGame
|
|
instance ToJSON PublicGame where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
data T =
|
|
Relay {from :: PlayerID, message :: FromClient}
|
|
| Welcome {room :: Room, key :: PlayerID}
|
|
| Update {alone :: [PlayerID], paired :: [PlayerID]}
|
|
| Game {game :: PublicGame, logs :: [KoiKoi.Action]}
|
|
| Pong
|
|
| Error {error :: String}
|
|
deriving (Generic)
|
|
|
|
instance FromJSON T
|
|
instance ToJSON T where
|
|
toEncoding = genericToEncoding defaultOptions
|