95 lines
2.6 KiB
Haskell
95 lines
2.6 KiB
Haskell
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Hanafuda.Message (
|
|
) where
|
|
|
|
import Data.Char (toLower)
|
|
import Data.Aeson (
|
|
FromJSON(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..)
|
|
, Value, (.=), defaultOptions, eitherDecode', encode, genericParseJSON
|
|
, genericToEncoding, object, pairs
|
|
)
|
|
import Data.Aeson.Types (toJSONKeyText)
|
|
import Data.Map (Map)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text (pack)
|
|
import GHC.Generics (Generic)
|
|
import qualified Hanafuda (Card(..))
|
|
import Hanafuda.Key (Key(..), getKey)
|
|
import Hanafuda.KoiKoi (PlayerKey)
|
|
import qualified Hanafuda.KoiKoi as KoiKoi (Action(..), Game(..), Move(..), Source(..))
|
|
|
|
deriving instance Generic PlayerKey
|
|
instance FromJSON PlayerKey
|
|
instance ToJSON PlayerKey where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
instance ToJSONKey PlayerKey where
|
|
toJSONKey = toJSONKeyText (Text.pack . getKey)
|
|
|
|
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 :: PlayerKey}
|
|
| 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)
|
|
|
|
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 PlayerKey PlayerStatus
|
|
|
|
deriving instance Generic KoiKoi.Source
|
|
instance ToJSON KoiKoi.Source
|
|
|
|
deriving instance Generic KoiKoi.Action
|
|
instance ToJSON KoiKoi.Action
|
|
|
|
data T =
|
|
Relay {from :: PlayerKey, message :: FromClient}
|
|
| Welcome {room :: Room, key :: PlayerKey}
|
|
| Update {alone :: [PlayerKey], paired :: [PlayerKey]}
|
|
| Game {game :: Value, logs :: [KoiKoi.Action]}
|
|
| Pong
|
|
| Error {error :: String}
|
|
deriving (Generic)
|
|
|
|
instance ToJSON T where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|