generalize skat online ai to use a general communicator type

src/Skat/AI/Online.hs

@@ -5,7 +5,6 @@
 module Skat.AI.Online where
 
 import Control.Monad.Reader
-import Network.WebSockets (Connection, sendTextData, receiveData)
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as BS
 
@@ -15,19 +14,22 @@ import Skat.Pile
 import Skat.Card
 import Skat.Render
 
+class Communicator a where
+    send :: a -> String -> IO ()
+    receive :: a -> IO String
+
 class Monad m => MonadClient m where
     query :: String -> m ()
     response :: m String
 
-data OnlineEnv = OnlineEnv { getTeam :: Team
-                           , getHand :: Hand
-                           , connection :: Connection }
-                 deriving Show
+data OnlineEnv c = OnlineEnv { getTeam :: Team
+                             , getHand :: Hand
+                             , connection :: c }
 
-instance Show Connection where
-    show _ = "A connection"
+instance Show (OnlineEnv c) where
+    show _ = "An online env"
 
-instance Player OnlineEnv where
+instance Communicator c => Player (OnlineEnv c) where
     team = getTeam
     hand = getHand
     chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p)
@@ -35,22 +37,22 @@ instance Player OnlineEnv where
     onGameResults p res = runReaderT (onResults res) p
     onGameStart p singlePlayer = runReaderT (onStart singlePlayer) p
 
-type Online m = ReaderT OnlineEnv m
+type Online a m = ReaderT (OnlineEnv a) m
 
-instance MonadIO m => MonadClient (Online m) where
+instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
     query s = do
         conn <- asks connection
-        liftIO $ sendTextData conn (BS.pack s)
+        liftIO $ send conn s
     response = do
         conn <- asks connection
-        liftIO $ BS.unpack <$> receiveData conn
+        liftIO $ receive conn
 
-instance MonadPlayer m => MonadPlayer (Online m) where
+instance MonadPlayer m => MonadPlayer (Online a m) where
     trumpColour = lift $ trumpColour
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
-choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online m Card
+choose :: (Communicator c, MonadPlayer m) => [CardS Played] -> [Card] -> Online c m Card
 choose table hand = do
     query (BS.unpack $ encode $ ChooseQuery hand table)
     r <- response
@@ -60,13 +62,13 @@ choose table hand = do
             if card `elem` hand && allowed then return card else choose table hand
         Nothing -> choose table hand
 
-cardPlayed :: MonadPlayer m => CardS Played -> Online m ()
+cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 
-onResults :: MonadIO m => (Int, Int) -> Online m ()
+onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m ()
 onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
 
-onStart :: MonadPlayer m => Hand -> Online m ()
+onStart :: (Communicator c, MonadPlayer m) => Hand -> Online c m ()
 onStart singlePlayer = do
     trCol <- trumpColour
     ownHand <- asks getHand

src/Skat/Matches.hs

@@ -32,12 +32,12 @@ cardDistr = Piles hands [] (map (putAt SkatP) skt)
             ++ map (putAt Hand3) hand3
           skt = [Card Nine Clubs, Card Queen Clubs]
 
-singleVsBots :: (Team -> Hand -> OnlineEnv) -> IO ()
-singleVsBots mkPlayer = do
+singleVsBots :: Communicator c => c -> IO ()
+singleVsBots comm = do
     --let gen = mkStdGen 123
     --    cards = shuffleCardsWithGen gen
     let ps = Players
-                (PL $ mkPlayer Team Hand1)
+                (PL $ OnlineEnv Team Hand1 comm)
                 (PL $ Stupid Team Hand2)
                 (PL $ mkAIEnv Single Hand3 10)
         env = SkatEnv cardDistr Nothing Spades ps