introduce stack build system and restructure code

src/Skat/AI/Online.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+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
+
+import Skat.Player
+import qualified Skat.Player.Utils as P
+import Skat.Pile
+import Skat.Card
+import Skat.Render
+
+class Monad m => MonadClient m where
+    query :: String -> m ()
+    response :: m String
+
+data OnlineEnv = OnlineEnv { getTeam :: Team
+                           , getHand :: Hand
+                           , connection :: Connection }
+                 deriving Show
+
+instance Show Connection where
+    show _ = "A connection"
+
+instance Player OnlineEnv where
+    team = getTeam
+    hand = getHand
+    chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p)
+    onCardPlayed p c = runReaderT (cardPlayed c) p >> return p
+    onGameResults p res = runReaderT (onResults res) p
+
+type Online m = ReaderT OnlineEnv m
+
+instance MonadIO m => MonadClient (Online m) where
+    query s = do
+        conn <- asks connection
+        liftIO $ sendTextData conn (BS.pack s)
+    response = do
+        conn <- asks connection
+        liftIO $ BS.unpack <$> receiveData conn
+
+instance MonadPlayer m => MonadPlayer (Online m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online m Card
+choose table hand = do
+    query (BS.unpack $ encode $ ChooseQuery hand table)
+    r <- response
+    case decode (BS.pack r) of
+        Just (ChosenResponse card) -> do
+            allowed <- P.isAllowed hand card
+            if card `elem` hand && allowed then return card else choose table hand
+        Nothing -> choose table hand
+
+cardPlayed :: MonadPlayer m => CardS Played -> Online m ()
+cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
+
+onResults :: MonadIO m => (Int, Int) -> Online m ()
+onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
+
+data ChooseQuery = ChooseQuery [Card] [CardS Played]
+data CardPlayedQuery = CardPlayedQuery (CardS Played)
+data GameResultsQuery = GameResultsQuery Int Int
+data ChosenResponse = ChosenResponse Card
+
+instance ToJSON ChooseQuery where
+    toJSON (ChooseQuery hand table) =
+        object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
+
+instance ToJSON CardPlayedQuery where
+    toJSON (CardPlayedQuery card) =
+        object ["query" .= ("card_played" :: String), "card" .= card]
+
+instance ToJSON GameResultsQuery where
+    toJSON (GameResultsQuery sgl tm) =
+        object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm]
+
+instance FromJSON ChosenResponse where
+    parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
+        <$> v .: "card"