packages feed

macbeth-lib (empty) → 0.0.12

raw patch · 54 files changed

+3940/−0 lines, 54 filesdep +FindBindep +MissingHdep +attoparsecsetup-changed

Dependencies added: FindBin, MissingH, attoparsec, base, bytestring, conduit, conduit-extra, containers, directory, either-unwrap, filepath, hspec, macbeth-lib, mtl, network, old-locale, resourcet, safe, sodium, split, stm, text, time, transformers, wx, wxcore, yaml

Files

+ LICENSE view
@@ -0,0 +1,15 @@+Macbeth - A beautiful FICS client+Copyright (C) 2016 Tilmann Gass ++This program is free software: you can redistribute it and/or modify+it under the terms of the GNU Affero General Public License as+published by the Free Software Foundation, either version 3 of the+License, or (at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+GNU Affero General Public License for more details.++You should have received a copy of the GNU Affero General Public License+along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ macbeth-lib.cabal view
@@ -0,0 +1,83 @@+name: macbeth-lib+synopsis: Macbeth - A beautiful and minimalistic FICS client+description: A FICS client written with OSX in mind.+author: Tilmann Gass+maintainer: tilmann@macbeth-ficsclient.com+homepage: http://www.macbeth-ficsclient.com+bug-reports: https://github.com/tgass/macbeth/issues+category: game+version: 0.0.12+cabal-version: >= 1.8+build-type: Simple+license: GPL+license-file: LICENSE+data-dir: resources+extra-source-files: test/*.hs+source-repository head+  type: git+  location: https://github.com/tgass/macbeth++library+    build-depends: base >=4.2 && <5, wxcore, wx, network, conduit, conduit-extra, text, transformers, resourcet,+                   bytestring, split, attoparsec, filepath, containers, split, mtl, stm, sodium, directory, filepath,+                   time, MissingH, old-locale, safe, FindBin, yaml, either-unwrap+    hs-source-dirs: src+    exposed-modules: Paths,+                     Macbeth.Fics.FicsConnection+                     Macbeth.Fics.FicsMessage,+                     Macbeth.Fics.Configuration,+                     Macbeth.Fics.Api.Api,+                     Macbeth.Fics.Api.Challenge,+                     Macbeth.Fics.Api.Game,+                     Macbeth.Fics.Api.Move,+                     Macbeth.Fics.Api.Rating,+                     Macbeth.Fics.Api.PendingOffer,+                     Macbeth.Fics.Api.Seek,+                     Macbeth.Fics.Api.Player,+                     Macbeth.Fics.Parsers.Api,+                     Macbeth.Fics.Parsers.FicsMessageParser,+                     Macbeth.Fics.Parsers.GamesParser,+                     Macbeth.Fics.Parsers.MoveParser,+                     Macbeth.Fics.Parsers.PositionParser,+                     Macbeth.Fics.Parsers.Players,+                     Macbeth.Fics.Parsers.RatingParser,+                     Macbeth.Fics.Parsers.SeekMsgParsers,+                     Macbeth.Fics.Utils.Bitmask,+                     Macbeth.Utils.BoardUtils,+                     Macbeth.Utils.PGN,+                     Macbeth.Utils.FEN,+                     Macbeth.Utils.Utils,+                     Macbeth.Wx.BoardState,+                     Macbeth.Wx.Board,+                     Macbeth.Wx.Challenge,+                     Macbeth.Wx.StatusPanel,+                     Macbeth.Wx.Configuration,+                     Macbeth.Wx.Finger,+                     Macbeth.Wx.GamesList,+                     Macbeth.Wx.GameMoves,+                     Macbeth.Wx.GameType,+                     Macbeth.Wx.Login,+                     Macbeth.Wx.Match,+                     Macbeth.Wx.Game,+                     Macbeth.Wx.Pending,+                     Macbeth.Wx.PartnerOffer,+                     Macbeth.Wx.PieceSet,+                     Macbeth.Wx.PlayersList,+                     Macbeth.Wx.Seek,+                     Macbeth.Wx.SoughtList,+                     Macbeth.Wx.ToolBox,+                     Macbeth.Wx.Utils+  other-modules: Paths_Macbeth+  ghc-options: -W++executable Macbeth+  main-is: src/Macbeth.hs+  build-depends: base  >= 4.2, wx, wxcore, macbeth-lib, stm+  ghc-options: -O3 -threaded -W++test-suite macbeth-lib-test+    type: exitcode-stdio-1.0+    ghc-options: -W+    hs-source-dirs: test+    main-is: Spec.hs+    build-depends: macbeth-lib, base, hspec == 2.*, bytestring, attoparsec
+ src/Macbeth.hs view
@@ -0,0 +1,11 @@+module Main where++import Macbeth.Fics.FicsConnection+import Macbeth.Wx.ToolBox++import Graphics.UI.WX++main :: IO ()+main = do+  (h, chan) <- ficsConnection+  start $ wxToolBox h chan
+ src/Macbeth/Fics/Api/Api.hs view
@@ -0,0 +1,51 @@+module Macbeth.Fics.Api.Api (+  PColor (..),+  Piece (..),+  PType (..),+  Square (..),+  Row (..),+  Column (..),+  Position,+  MoveDetailed (..),+  Username,+  pColor,+  invert+) where++import Data.Char++data Column = A | B | C | D | E | F | G | H deriving (Show, Enum, Bounded, Eq)++data Row = One | Two | Three | Four | Five | Six | Seven | Eight deriving (Show, Eq, Enum, Bounded)++data Square = Square Column Row deriving (Eq)++instance Show Square where+  show (Square s y) = fmap toLower (show s) ++ show (fromEnum y + 1)++data PType = Pawn | Rook | Knight | Bishop | Queen | King deriving (Ord, Eq)++instance Show PType where+  show Pawn = "P"+  show Rook = "R"+  show Knight = "N"+  show Bishop = "B"+  show Queen = "Q"+  show King = "K"++data PColor = Black | White deriving (Show, Eq, Read)++data Piece = Piece PType PColor deriving (Show, Eq)++type Position = [(Square, Piece)]++data MoveDetailed = Simple Square Square | Drop Square | CastleLong | CastleShort deriving (Show, Eq)++type Username = String++pColor :: Piece -> PColor+pColor (Piece _ color) = color++invert :: PColor -> PColor+invert White = Black+invert Black = White
+ src/Macbeth/Fics/Api/Challenge.hs view
@@ -0,0 +1,15 @@+module Macbeth.Fics.Api.Challenge (+  Challenge (..),+  displayChallenge+) where++import Macbeth.Fics.Api.Rating++data Challenge = Challenge { nameW :: String+                           , ratingW :: Rating+                           , nameB :: String+                           , ratingB :: Rating+                           , params :: String } deriving (Show, Eq)++displayChallenge :: Challenge -> String+displayChallenge c = nameW c ++ " (" ++ show (ratingW c) ++ ") vs. " ++ nameB c ++ " (" ++ show (ratingB c) ++ ") " ++ params c
+ src/Macbeth/Fics/Api/Game.hs view
@@ -0,0 +1,43 @@+module Macbeth.Fics.Api.Game (+  Game (..),+  GameType (..),+  GameSettings (..),+  GameResult (..),+  GameInfo (..)+) where++import Macbeth.Fics.Api.Rating++data GameType =  Blitz | Lightning | Untimed | ExaminedGame | Standard | Wild | Atomic |+                 Crazyhouse | Bughouse | Losers | Suicide | NonStandardGame  deriving (Show, Eq)++data Game = Game {+    id :: Int+  , isExample :: Bool+  , isSetup :: Bool+  , ratingW :: Rating+  , nameW :: String+  , ratingB :: Rating+  , nameB :: String+  , settings :: GameSettings } deriving (Show, Eq)++data GameSettings = GameSettings {+    isPrivate :: Bool+  , gameType :: GameType+  , isRated :: Bool} deriving (Show, Eq)++data GameInfo = GameInfo {+    _nameW :: String+  , _ratingW :: Rating+  , _nameB :: String+  , _ratingB :: Rating+} deriving (Show, Eq)++data GameResult = WhiteWins | BlackWins | Draw | Aborted deriving (Eq)++instance Show GameResult where+  show WhiteWins = "1-0"+  show BlackWins = "0-1"+  show Draw      = "1/2-1/2"+  show Aborted   = ""+
+ src/Macbeth/Fics/Api/Move.hs view
@@ -0,0 +1,156 @@+module Macbeth.Fics.Api.Move (+  Move(..),+  Relation(..),+  Castling(..),+  MoveModifier(..),+  remainingTime,+  decreaseRemainingTime,+  nameUser,+  colorUser,+  namePlayer,+  isGameUser,+  isNextMoveUser,+  isNewGameUser,+  isOponentMove,+  wasOponentMove,+  playerColor,+  nameOponent,+  isCheckmate,+  toGameResultTuple,+  dummyMove+) where++import Macbeth.Fics.Api.Api+import qualified Macbeth.Fics.Api.Game as Game++import Data.Maybe++data Move = Move {+    positionRaw :: String+  , position :: [(Square, Piece)]+  , turn :: PColor+  , doublePawnPush :: Maybe Column+  , castlingAv :: [Castling]+  , ply :: Int+  , gameId :: Int+  , nameW :: String+  , nameB :: String+  , relation :: Relation+  , initialTime :: Int+  , incPerMove :: Int+  , whiteRelStrength :: Int+  , blackRelStrength :: Int+  , remainingTimeW :: Int+  , remainingTimeB :: Int+  , moveNumber :: Int+  , moveVerbose :: Maybe MoveDetailed+  , timeTaken :: String+  , movePretty :: Maybe String+  } deriving (Eq, Show)++data Relation = IsolatedPosition | ObservingExaminedGame | Examiner | MyMove | OponentsMove | Observing deriving (Show, Eq)++data Castling = WhiteLong | WhiteShort | BlackLong | BlackShort deriving (Show, Eq)++data MoveModifier = None | Illegal | Takeback (Maybe Username) deriving (Eq)++instance Show MoveModifier where+  show Illegal = "Illegal move."+  show (Takeback (Just username)) = username ++ " accepts the takeback request."+  show (Takeback Nothing) = ""+  show None = ""++remainingTime :: PColor -> Move -> Int+remainingTime Black = remainingTimeB+remainingTime White = remainingTimeW+++decreaseRemainingTime :: PColor -> Move -> Move+decreaseRemainingTime Black move = move {remainingTimeB = max 0 $ remainingTimeB move - 1}+decreaseRemainingTime White move = move {remainingTimeW = max 0 $ remainingTimeW move - 1}+++nameUser :: Move -> String+nameUser m = namePlayer (colorUser m) m+++colorUser :: Move -> PColor+colorUser m = if relation m == MyMove then turn m else invert $ turn m+++isGameUser :: Move -> Bool+isGameUser m = relation m `elem` [MyMove, OponentsMove]+++isNextMoveUser :: Move -> Bool+isNextMoveUser m = relation m == MyMove+++isNewGameUser :: Move -> Bool+isNewGameUser m = isGameUser m && isNothing (movePretty m)+++isOponentMove :: Move -> Bool+isOponentMove m = relation m == OponentsMove+++wasOponentMove :: Move -> Bool+wasOponentMove m = colorUser m == turn m+++namePlayer :: PColor -> Move -> String+namePlayer White = nameW+namePlayer Black = nameB+++nameOponent :: Move -> String+nameOponent m = namePlayer (invert $ colorUser m) m+++playerColor :: String -> Move -> PColor+playerColor name move+  | nameW move == name = White+  | otherwise = Black+++isCheckmate :: Move -> Bool+isCheckmate = maybe False ((== '#') . last) . movePretty+++toGameResultTuple :: Move -> (Int, String, Game.GameResult)+toGameResultTuple move = (gameId move, namePlayer colorTurn move ++ " checkmated", turnToGameResult colorTurn)+  where+    colorTurn = turn move+    turnToGameResult Black = Game.WhiteWins+    turnToGameResult White = Game.BlackWins+++dummyMove :: Move+dummyMove = Move {+    positionRaw = "",+    position = [ (Square A One, Piece Rook White)+                   , (Square A Two, Piece Pawn White)+                   , (Square B Two, Piece Pawn White)+                   , (Square C Two, Piece Pawn White)+                   , (Square E Eight, Piece King Black)+                   , (Square D Eight, Piece Queen Black)+                   ],+    turn = Black,+    doublePawnPush = Nothing,+    castlingAv = [],+    ply = 0,+    gameId = 1,+    nameW = "foobar",+    nameB = "barbaz",+    relation = MyMove,+    moveNumber = 0,+    moveVerbose = Nothing,+    timeTaken = "0",+    remainingTimeW = 0,+    remainingTimeB = 0,+    movePretty = Just "f2"+  , initialTime = 300+  , incPerMove = 0+  , whiteRelStrength = 120+  , blackRelStrength = 120+  }
+ src/Macbeth/Fics/Api/PendingOffer.hs view
@@ -0,0 +1,23 @@+module Macbeth.Fics.Api.PendingOffer (+  PendingOffer(..),+  Origin (..),+  isFrom,+  isTo+) where++import Macbeth.Fics.Api.Player++data Origin = From | To deriving (Show, Eq)++data PendingOffer = PendingOffer {+    origin :: Origin+  , offerId :: Int+  , playerName :: UserHandle+  , offerType :: String+  , params :: String } deriving (Show, Eq)++isFrom :: PendingOffer -> Bool+isFrom = (== From) . origin++isTo :: PendingOffer -> Bool+isTo = (== To) . origin
+ src/Macbeth/Fics/Api/Player.hs view
@@ -0,0 +1,45 @@+module Macbeth.Fics.Api.Player (+  Player (..),+  Status (..),+  UserHandle (..),+  HandleType (..)+) where++import Macbeth.Fics.Api.Rating hiding (None)++data Player = Player {+    rating :: Rating+  , status :: Status+  , handle :: UserHandle } deriving (Eq, Show)++data Status = InvolvedInAGame+            | RunningASimulMatch+            | NotOpenForMatch+            | ExaminingAGame+            | InactiveOrBusy+            | NotBusy+            | InvolvedInATournament deriving (Eq, Show)+++data UserHandle = UserHandle {+    name :: String+  , handleType :: [HandleType] } deriving (Eq, Show)+++data HandleType = Admin+                | Blindfold+                | Computer+                | NOT_DOCUMENTED -- ^ (D) is not documented+                | Team+                | Unregistered+                | ChessAdvisor+                | ServiceRepresentative+                | TournamentDirectorOrBot+                | MamerManager+                | GrandMaster+                | InternationalMaster+                | FideMaster+                | WomenGrandMaster+                | WomenInternationalMaster+                | WomenFideMaster deriving (Eq, Show)+
+ src/Macbeth/Fics/Api/Rating.hs view
@@ -0,0 +1,19 @@+module Macbeth.Fics.Api.Rating (+  Rating (..),+  ProvShow (..)+) where++data Rating = Rating {r :: Int, provShow :: ProvShow} | Unrated | Guest deriving (Eq)++data ProvShow = None | Estimated | Provisional deriving (Eq)++instance Show ProvShow where+  show None = ""+  show Estimated = "E"+  show Provisional = "P"++instance Show Rating where+  show (Rating r' ps) = show r' ++ show ps+  show Guest = "Guest"+  show Unrated = "Unrated"+
+ src/Macbeth/Fics/Api/Seek.hs view
@@ -0,0 +1,38 @@+module Macbeth.Fics.Api.Seek (+  Seek (..),+  StartMode,+  Title (..)+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Game+import Macbeth.Fics.Api.Rating+import Macbeth.Fics.Utils.Bitmask++data Seek = Seek {+    id :: Int+  , name :: String+  , titles :: [Title] -- It is unlikely the titles will ever be mixed though as they should be exclusive. However the server does allow this.+  , rating :: Rating+  , timeStart :: Int+  , timeIncPerMove :: Int+  , isRated :: Bool+  , gameType :: GameType+  , color :: Maybe PColor+  , ratingRange :: (Int, Int)+--                 , startMode :: StartMode+--                 , checkFormula :: Bool+} deriving (Eq, Show)++data StartMode = Auto | Manual deriving (Show)++data Title =   Unregistered+             | Computer+             | GrandMaster+             | InternationalMaster+             | FideMaster+             | WomenGrandMaster+             | WomenInternationalMaster+             | WomenFideMaster deriving (Bounded, Enum, Eq, Show)++instance ToBitMask Title
+ src/Macbeth/Fics/Configuration.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveGeneric #-}+module Macbeth.Fics.Configuration (+  Config(..),+  Logging(..),+  loadConfig,+  loadDefaultConfig,+  saveConfig+) where++import Paths++import Control.Monad.Except+import Data.Either.Unwrap+import System.Directory+import System.FilePath+import GHC.Generics+import qualified Data.Yaml as Y++data Config = Config {+  directory :: Maybe FilePath,+  logging :: Logging+} deriving (Show, Generic)++data Logging = Logging {+  stdOut :: Bool,+  file :: Bool+} deriving (Show, Generic)++instance Y.FromJSON Config+instance Y.ToJSON Config++instance Y.FromJSON Logging+instance Y.ToJSON Logging+++loadConfig :: IO Config+loadConfig = fmap fromRight $ runExceptT $ fromDisk `catchError` (\_ -> return defaultConfig)++loadDefaultConfig :: IO Config+loadDefaultConfig = do+  dir <- getDefaultDirectory Nothing+  return $ defaultConfig {directory = Just dir}+++-- | If no directory is set, set default directory ~/Macbeth+fromDisk :: ExceptT Y.ParseException IO Config+fromDisk = do+  config <- ExceptT $ getDataFileName "macbeth.yaml" >>= Y.decodeFileEither+  dir <- liftIO $ getDefaultDirectory (directory config)+  return $ config {directory = Just dir}++-- | Create default directory if it doesn't exist+getDefaultDirectory :: Maybe FilePath -> IO FilePath+getDefaultDirectory Nothing = do+  dir <- (</> "Macbeth") `fmap` getUserDocumentsDirectory+  createDirectoryIfMissing False dir+  return dir+getDefaultDirectory (Just path) = return path++saveConfig :: Config -> IO ()+saveConfig config = getDataFileName "macbeth.yaml" >>= flip Y.encodeFile config++defaultConfig = Config {+  directory = Nothing,+  logging = Logging False False+}+
+ src/Macbeth/Fics/FicsConnection.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Macbeth.Fics.FicsConnection (+  ficsConnection+) where++import Macbeth.Fics.Configuration+import Macbeth.Fics.FicsMessage hiding (gameId)+import Macbeth.Fics.Api.Move hiding (Observing)+import Macbeth.Fics.Parsers.FicsMessageParser++import Control.Concurrent.Chan+import Control.Monad+import Control.Monad.State+import Control.Monad.Trans.Resource+import Data.Char+import Data.Conduit+import Data.Conduit.Binary+import Data.Conduit.List hiding (filter)+import Data.Maybe+import Data.Time+import Network+import System.FilePath+import System.IO++import qualified Data.ByteString.Char8 as BS+++data HelperState = HelperState { config :: Config+                               , takebackAccptedBy :: Maybe String -- ^ oponent accepted takeback request+                               , observingGameId :: Maybe Int+                               , newGameId :: Maybe Int }+++ficsConnection :: IO (Handle, Chan FicsMessage)+ficsConnection = runResourceT $ do+  (_, hsock) <- allocate (connectTo "freechess.org" $ PortNumber 5000) hClose+  liftIO $ hSetBuffering hsock LineBuffering+  config <- liftIO loadConfig+  chan <- liftIO newChan+  resourceForkIO $ liftIO $ chain hsock config chan+  return (hsock, chan)+++chain :: Handle -> Config-> Chan FicsMessage -> IO ()+chain h config chan = flip evalStateT emptyState $ transPipe lift+  (sourceHandle h) $$+  linesC =$+  blockC BS.empty =$+  unblockC =$+  fileLoggerC =$+  parseC =$+  stateC =$+  copyC chan =$+  loggingC =$+  sink chan+  where emptyState = HelperState config Nothing Nothing Nothing+++sink :: Chan FicsMessage -> Sink FicsMessage (StateT HelperState IO) ()+sink chan = awaitForever $ liftIO . writeChan chan+++loggingC :: Conduit FicsMessage (StateT HelperState IO) FicsMessage+loggingC = awaitForever $ \cmd -> do+  logToStdOut <- (stdOut . logging . config) `fmap` get+  when logToStdOut $ liftIO (printCmdMsg cmd)+  yield cmd+++copyC :: Chan FicsMessage -> Conduit FicsMessage (StateT HelperState IO) FicsMessage+copyC chan = awaitForever $ \case+  m@(MatchAccepted move) -> do+    chan' <- liftIO $ dupChan chan+    sourceList [m, WxMatchAccepted move chan']+  m@(Observe move) -> do+    chan' <- liftIO $ dupChan chan+    sourceList [m, WxObserve move chan']+  cmd -> yield cmd+++stateC :: Conduit FicsMessage (StateT HelperState IO) FicsMessage+stateC = awaitForever $ \cmd -> do+  state <- get+  case cmd of+    GameCreation id -> do+      put $ state {newGameId = Just id}+      sourceNull++    Observing id -> do+      put $ state {observingGameId = Just id}+      sourceNull++    TakebackAccepted username -> do+      put $ state {takebackAccptedBy = Just username}+      sourceNull++    m@(GameMove _ move)+      | isCheckmate move && isOponentMove move -> sourceList $ cmd : [toGameResult move]+      | isNewGameUser move && fromMaybe False ((== gameId move) <$> newGameId state) -> do+          put $ state {newGameId = Nothing }+          sourceList [MatchAccepted move]+      | fromMaybe False ((== gameId move) <$> observingGameId state) -> do+          put $ state {observingGameId = Nothing }+          sourceList [Observe move]+      | isJust $ takebackAccptedBy state -> do+          put $ state {takebackAccptedBy = Nothing}+          sourceList [m{context = Takeback $ takebackAccptedBy state}]+      | otherwise -> sourceList [m]++    _ -> yield cmd+++parseC :: Conduit BS.ByteString (StateT HelperState IO) FicsMessage+parseC = awaitForever $ \str -> case parseFicsMessage str of+  Left _    -> yield $ TextMessage $ BS.unpack str+  Right cmd -> yield cmd+++unblockC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString+unblockC = awaitForever $ \block -> case ord $ BS.head block of+  21 -> if readId block `elem` [+       1 -- game move+    , 10 -- Abort+    , 11 -- Accept (Draw, Abort)+    , 33 -- Decline (ie match offer)+    , 34 -- Draw (Mutual)+    , 80 -- Observing+    , 103 -- Resign+    , 155 -- Seek (Users' seek matches a seek already posted)+    , 158 -- Play (User selects a seek)+    , 56 -- BLK_ISET, seekinfo set.+    ]+    then sourceList (lines $ crop block) else yield block+  _ -> yield block+  where+    crop :: BS.ByteString -> BS.ByteString+    crop bs = let lastIdx = maybe 0 (+1) (BS.elemIndexEnd (chr 22) bs) in+              BS.drop lastIdx $ BS.init bs++    lines :: BS.ByteString -> [BS.ByteString]+    lines bs = fmap (`BS.snoc` '\n') $ init $ filter (not . BS.null) $ BS.split '\n' bs++    readId :: BS.ByteString -> Int+    readId = read . BS.unpack . BS.takeWhile (/= chr 22) . BS.tail . BS.dropWhile (/= chr 22)+++blockC :: BS.ByteString -> Conduit BS.ByteString (StateT HelperState IO) BS.ByteString+blockC block = awaitForever $ \line -> case ord $ BS.head line of+  21 -> blockC line+  23 -> yield (block `BS.append` line) >> blockC BS.empty -- ^ don't ever delete this again!+  _ | BS.null block -> unless (line `elem` ignore) $ yield line+    | otherwise -> blockC $ block `BS.append` line+  where ignore = [BS.pack "\n", BS.pack "\a\n"]+++-- remember!! "fics% \NAK4\SYN87\SYNThere are no offers pending to other players."+linesC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString+linesC = awaitForever $ sourceList . filter (not . BS.null) . fmap dropPrompt . BS.split '\r'+++dropPrompt :: BS.ByteString -> BS.ByteString+dropPrompt line+  | BS.take promptSz line == prompt = BS.drop promptSz line+  | otherwise = line+  where prompt = BS.pack "fics% "+        promptSz = BS.length prompt+++fileLoggerC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString+fileLoggerC = awaitForever $ \chunk -> do+   config <- config `fmap` get+   when (file (logging config) && isJust (directory config)) $+     liftIO $ logFile (fromJust $ directory config) chunk+   yield chunk+++toGameResult :: Move -> FicsMessage+toGameResult move = GameResult id reason result+  where (id, reason, result) = toGameResultTuple move+++printCmdMsg :: FicsMessage -> IO ()+printCmdMsg NewSeek {} = return ()+printCmdMsg RemoveSeeks {} = return ()+printCmdMsg cmd = print cmd+++logFile :: FilePath -> BS.ByteString -> IO ()+logFile path chunk = do+  date <- fmap (formatTime Data.Time.defaultTimeLocale "%Y-%m-%d_") getZonedTime+  dateTime <- fmap (formatTime Data.Time.defaultTimeLocale "%Y-%m-%d %H-%M-%S: ") getZonedTime+  appendFile (path </> date ++ "macbeth.log") $+    (foldr (.) (showString $ "\n" ++ dateTime) $ fmap showLitChar (BS.unpack chunk)) ""+
+ src/Macbeth/Fics/FicsMessage.hs view
@@ -0,0 +1,99 @@+module Macbeth.Fics.FicsMessage (+  FicsMessage (..)+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Player+import Macbeth.Fics.Api.Challenge+import Macbeth.Fics.Api.Game+import Macbeth.Fics.Api.Move+import Macbeth.Fics.Api.PendingOffer+import Macbeth.Fics.Api.Seek++import Control.Concurrent.Chan++data FicsMessage =+  -- | 1. Confirmation of a user move+  --   2. Reseted position after illegal user move+  --   3. Move by oponent+    GameMove { context :: MoveModifier, move :: Move }++  -- | Pieces holdings in Bughouse / Crazyhouse games+  | PieceHolding { gameId :: Int, phWhite :: [PType], phBlack :: [PType] }++  -- | Answer to 'observe' command (BLK_OBSERVE 80)+  | Observe Move++  -- | If id in 'observe id' does not exist+  | NoSuchGame+  | UserNotLoggedIn Username++  -- | Match offered by another player+  | MatchRequested Challenge++  -- | Starts a new game. Let it be after 'seek' or 'match' or resuming a pending game.+  -- Indifferent of whether the user or his oponent started the interaction.+  | MatchAccepted Move+  | MatchDeclined Username+  | MatchUserNotLoggedIn Username++  -- | Not concering if the user or his oponent is checkmated/out of time/.. GameResult informs+  -- that the game is over.+  | GameResult { gameId :: Int, reason :: String, result :: GameResult }++  | Pending PendingOffer+  | PendingRemoved Int++  -- | The oponents wants to draw.+  | DrawRequest+  | DrawRequestDeclined Username++  -- | The oponent wants to abort.+  | AbortRequest Username+  | AbortRequestDeclined Username++  -- | The oponent wants to takeback one or more half-moves+  | TakebackRequest Username Int++  -- | Promotion piece+  | PromotionPiece PType++  | NewSeek Seek+  | RemoveSeeks [Int]+  | ClearSeek+  | SeekNotAvailable++  | PartnerNotOpen UserHandle+  | PartnerOffer UserHandle+  | PartnerAccepted UserHandle+  | PartnerDeclined UserHandle++  -- | Answer to 'games' command (BLK_GAMES 43)+  | Games [Game]+  | Players [Player]+  | Finger UserHandle String+  | History UserHandle String+  | Ping {lagMin :: Int, lagAvg :: Int, lagMax :: Int}++  | Login+  | LoginTimeout+  | Password+  | GuestLogin Username+  | LoggedIn UserHandle+  | InvalidPassword+  | TextMessage String++  {- Unused -}+  | UnkownUsername Username++  {- Internal -}+  | GameCreation Int+  | Observing Int+  | TakebackAccepted Username+  | WxClose+  | WxMatchAccepted Move (Chan FicsMessage)+  | WxObserve Move (Chan FicsMessage) deriving (Show, Eq)++instance Show (Chan a) where+  show _ = "Chan"+
+ src/Macbeth/Fics/Parsers/Api.hs view
@@ -0,0 +1,20 @@+module Macbeth.Fics.Parsers.Api (+  commandHead+) where++import Data.Attoparsec.ByteString.Char8+import Data.Char+import qualified Data.ByteString.Char8 as BS++data CommandHead = CommandHead Int deriving (Show)++commandHead :: Int -> Parser CommandHead+commandHead code = do+  char $ chr 21+  id <- decimal+  char $ chr 22+  string $ BS.pack $ show code+  char $ chr 22+  return $ CommandHead id++
+ src/Macbeth/Fics/Parsers/FicsMessageParser.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.FicsMessageParser (+ parseFicsMessage+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Challenge+import Macbeth.Fics.FicsMessage hiding (move)+import Macbeth.Fics.Api.Game+import Macbeth.Fics.Api.Move hiding (Observing)+import Macbeth.Fics.Api.PendingOffer+import Macbeth.Fics.Parsers.Api+import Macbeth.Fics.Parsers.GamesParser+import Macbeth.Fics.Parsers.MoveParser+import Macbeth.Fics.Parsers.RatingParser+import qualified Macbeth.Fics.Parsers.Players as P+import qualified Macbeth.Fics.Parsers.SeekMsgParsers as SP++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8 as BS+++parseFicsMessage :: BS.ByteString -> Either String FicsMessage+parseFicsMessage = parseOnly parser where+  parser = choice [ SP.clearSeek+                  , SP.newSeek+                  , SP.removeSeeks+                  , SP.seekNotAvailable++                  , gameMove+                  , gameCreation+                  , pieceHolding++                  , challenge+                  , matchDeclined+                  , matchUserNotLoggedIn++                  , games+                  , observing+                  , noSuchGame+                  , userNotLoggedIn++                  , abortRequest+                  , abortRequestDeclined++                  , takebackRequest+                  , takebackAccepted+                  , acceptTakeback++                  , drawRequest+                  , drawRequestDeclined++                  , gameResult'++                  , promotionPiece++                  , P.finger+                  , P.history+                  , P.players+                  , P.partnerNotOpen+                  , P.partnerOffer+                  , P.partnerAccepted+                  , P.partnerDeclined++                  , pending+                  , pendingTo+                  , pendingRemoved+                  , pendingWithdraw++                  , login+                  , loginTimeout+                  , password+                  , guestLogin+                  , unknownUsername+                  , loggedIn+                  , invalidPassword+                  , ping+                  ]++gameMove :: Parser FicsMessage+gameMove = GameMove <$> pure None <*> move++gameCreation :: Parser FicsMessage+gameCreation = GameCreation <$> ("{Game " *> decimal <* takeTill (== ')') <* ") Creating ")++observing :: Parser FicsMessage+observing = Observing <$> ("You are now observing game " *> decimal)++noSuchGame :: Parser FicsMessage+noSuchGame = commandHead 80 *> "There is no such game." *> pure NoSuchGame++userNotLoggedIn :: Parser FicsMessage+userNotLoggedIn = UserNotLoggedIn <$> (commandHead 80 *> many1 letter_ascii <* " is not logged in.\n\ETB")++games :: Parser FicsMessage+games = Games <$> (commandHead 43 *> parseGamesList)++challenge :: Parser FicsMessage+challenge = MatchRequested <$> (Challenge+  <$> ("Challenge: " *> manyTill anyChar space)+  <*> ("(" *> skipSpace *> rating)+  <*> (") " *> manyTill anyChar space)+  <*> ("(" *> skipSpace *> rating)+  <*> (") " *> manyTill anyChar ".")) --unrated blitz 2 12."++matchDeclined :: Parser FicsMessage+matchDeclined = MatchDeclined <$> ("\"" *> manyTill anyChar "\" declines the match offer.")++matchUserNotLoggedIn :: Parser FicsMessage+matchUserNotLoggedIn = MatchUserNotLoggedIn <$> (commandHead 73 *> manyTill anyChar " " <* "is not logged in.")++drawRequest :: Parser FicsMessage+drawRequest = manyTill anyChar space *> "offers you a draw." *> pure DrawRequest++drawRequestDeclined :: Parser FicsMessage+drawRequestDeclined = DrawRequestDeclined <$> manyTill anyChar space <* "declines the draw request."++abortRequest :: Parser FicsMessage+abortRequest = AbortRequest <$> (manyTill anyChar " " <* "would like to abort the game;")++abortRequestDeclined :: Parser FicsMessage+abortRequestDeclined = AbortRequestDeclined <$> manyTill anyChar space <* "declines the abort request."++takebackRequest :: Parser FicsMessage+takebackRequest = TakebackRequest+  <$> manyTill anyChar " " <* "would like to take back "+  <*> decimal <* " half move(s)."++takebackAccepted :: Parser FicsMessage+takebackAccepted = TakebackAccepted <$> manyTill anyChar " " <* "accepts the takeback request."++acceptTakeback :: Parser FicsMessage+acceptTakeback = GameMove <$>+  pure (Takeback Nothing) <*> -- ^ User accepted takeback himself+  (commandHead 11 *> "You accept the takeback request from" *> takeTill (== '<') *> move)++gameResult' :: Parser FicsMessage+gameResult' = GameResult+  <$> (takeTill (== '{') *> "{Game " *> decimal)+  <*> (takeTill (== ')') *> ") " *> manyTill anyChar "} ")+  <*> ("1-0" *> pure WhiteWins <|> "0-1" *> pure BlackWins <|> "1/2-1/2" *> pure Draw <|> "*" *> pure Aborted)++promotionPiece :: Parser FicsMessage+promotionPiece = PromotionPiece <$> (commandHead 92 *> "Promotion piece set to " *>+  ("QUEEN" *> pure Queen <|> "BISHOP" *> pure Bishop <|> "KNIGHT" *> pure Knight <|> "ROOK" *> pure Rook <|> "KING" *> pure King))++pending :: Parser FicsMessage+pending = Pending <$> (PendingOffer+  <$> (("<pf>" *> pure From) <|> ("<pt>" *> pure To))+  <*> (" " *> decimal)+  <*> (" w=" *> P.userHandle)+  <*> (" t=" *> manyTill anyChar " ")+  <*> ("p=" *> manyTill anyChar "\n"))++pendingTo :: Parser FicsMessage+pendingTo = commandHead 73 *> takeTill (=='<') *> pending++pendingRemoved :: Parser FicsMessage+pendingRemoved = PendingRemoved <$> ("<pr> " *> decimal)++pendingWithdraw :: Parser FicsMessage+pendingWithdraw = commandHead 147 *> takeTill (=='<') *> pendingRemoved++login :: Parser FicsMessage+login = "login: " *> pure Login++loginTimeout :: Parser FicsMessage+loginTimeout = "**** LOGIN TIMEOUT ****" *> pure LoginTimeout++password :: Parser FicsMessage+password = "password: " *> pure Password++guestLogin :: Parser FicsMessage+guestLogin = GuestLogin <$> ("Press return to enter the server as \"" *> manyTill anyChar "\":")++unknownUsername :: Parser FicsMessage+unknownUsername = UnkownUsername <$> ("\"" *> manyTill anyChar "\" is not a registered name.")++loggedIn :: Parser FicsMessage+loggedIn = LoggedIn <$> ("**** Starting FICS session as " *> P.userHandle <* " ****")++invalidPassword :: Parser FicsMessage+invalidPassword = "**** Invalid password! ****" *> pure InvalidPassword++ping :: Parser FicsMessage+ping = Ping+  <$> (":min/avg/max/mdev = " *> round `fmap` double)+  <*> ("/" *> round `fmap` double)+  <*> ("/" *> round `fmap` double)
+ src/Macbeth/Fics/Parsers/GamesParser.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.GamesParser (+  parseGamesList+) where++import Macbeth.Fics.Api.Game+import Macbeth.Fics.Parsers.RatingParser++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+++parseGamesList :: Parser [Game]+parseGamesList = many' gameP++gameP :: Parser Game+gameP = Game+  <$> (takeTill (== '\n') *> "\n" *> many space *> decimal)+  <*> (many1 space *> option False ("(Exam." *> pure True))+  <*> (option False ("(Setup" *> pure True))+  <*> (many space *> rating)+  <*> (many1 space *> manyTill anyChar space)+  <*> (many space *> rating)+  <*> (many1 space *> manyTill anyChar (space <|> char ')'))+  <*> (takeTill (== '[') *> "[" *> settings')+++settings' :: Parser GameSettings+settings' = GameSettings+  <$> (space *> pure False <|> char 'p' *> pure True)+  <*> gameType'+  <*> (char 'u' *> pure False <|> char 'r' *> pure True)+++gameType' :: Parser GameType+gameType' =+  "b" *> pure Blitz <|>+  "l" *> pure Lightning <|>+  "u" *> pure Untimed <|>+  "e" *> pure ExaminedGame <|>+  "s" *> pure Standard <|>+  "w" *> pure Wild <|>+  "x" *> pure Atomic <|>+  "z" *> pure Crazyhouse <|>+  "B" *> pure Bughouse <|>+  "L" *> pure Losers <|>+  "S" *> pure Suicide <|>+  "n" *> pure NonStandardGame+
+ src/Macbeth/Fics/Parsers/MoveParser.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.MoveParser (+  move,+  moveOnly,+  pieceHolding,+  pieceHoldingOnly,+  verboseMove'+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.FicsMessage hiding (move, Observing)+import Macbeth.Fics.Parsers.PositionParser+import Macbeth.Fics.Api.Move hiding (relation)++import Control.Applicative+import Data.Attoparsec.ByteString.Char8 hiding (D)+import Data.Maybe+import qualified Data.Attoparsec.ByteString.Char8 as A (take)+import qualified Data.ByteString.Char8 as BS++--test = BS.pack "<12> --kr-bnr ppp-pppp --nqb--- ---p---- ---P-B-- --NQ---P PPP-PPP- R---KBNR W -1 1 1 0 0 1 345 GuestTVTH GuestPYFX -1 5 0 39 39 282 288 6 o-o-o (0:03) O-O-O 1 1 0"+--test2 = BS.pack "<12> --kr-bnr ppp-pppp --nqb--- ---p---- ---P-B-- --NQ---P PPP-PPP- R---KBNR W -1 1 1 0 0 1 345 GuestTVTH GuestPYFX -1 5 0 39 39 282 288 6 o-o (0:03) O-O-O 1 1 0"+--test3 = BS.pack "<12> r--k-b-n ppp-pppP --bpp-b- ---pp--N -------- --P--PB- PPP-pPPP R---R-K- W -1 0 0 0 0 0 408 CarlosFenix mandevil 0 2 0 43 28 48 31 27 B/@@-g6 (0:25) B@g6 0 1 0\n"++move :: Parser Move+move = "<12>" *> moveOnly++moveOnly :: Parser Move+moveOnly = do+  pos <- BS.unpack `fmap` (space *> A.take 71)+  Move+    <$> pure pos+    <*> pure (parsePosition pos)+    <*> (space *> ("B" *> pure Black <|> "W" *> pure White)) -- turn+    <*> (space *> ("-1" *> pure Nothing <|> Just `fmap` column)) -- doublePawnPush+    <*> (catMaybes <$> sequence [ castle WhiteShort, castle WhiteLong, castle BlackShort, castle BlackLong])+    <*> (space *> decimal) -- the number of moves made since the last irreversible move, halfmove clock+    <*> (space *> decimal) -- gameId+    <*> (space *> manyTill anyChar space) -- nameW+    <*> manyTill anyChar space -- nameB+    <*> relation+    <*> (space *> decimal) --initialTime+    <*> (space *> decimal) --inc per move+    <*> (space *> decimal) -- whiteRelStrength+    <*> (space *> decimal) -- blackRelStrength+    <*> (space *> (decimal <|> ("-" *> (decimal >>= pure . negate)))) -- remTimeWhite+    <*> (space *> (decimal <|> ("-" *> (decimal >>= pure . negate)))) -- remTimeBlack+    <*> (space *> decimal) -- moveNumber+    <*> (space *> verboseMove') -- moveVerbose+    <*> (space *> manyTill anyChar space) -- timeTaken+    <*> ("none" *> pure Nothing <|> Just `fmap` manyTill anyChar space) -- movePretty+++verboseMove' :: Parser (Maybe MoveDetailed)+verboseMove' = ("none" *> pure Nothing) <|> Just <$> (+  (Simple <$> (anyChar *> "/" *> square) <*> ("-" *> square <* takeTill (== ' '))) <|>+  (Drop <$> (anyChar *> "/@@-" *> square <* takeTill (== ' '))) <|>+  ("o-o-o" *> pure CastleLong) <|>+  ("o-o" *> pure CastleShort))+++castle :: Castling -> Parser (Maybe Castling)+castle c = space *> ("0" *> pure Nothing <|> "1" *> pure (Just c))+++square :: Parser Square+square = Square <$> columnAH <*> row+++columnAH :: Parser Column+columnAH =+  "a" *> pure A <|> "b" *> pure B <|> "c" *> pure C <|> "d" *> pure D <|>+  "e" *> pure E <|> "f" *> pure F <|> "g" *> pure G <|> "h" *> pure H+++row :: Parser Row+row =+  "1" *> pure One <|> "2" *> pure Two <|> "3" *> pure Three <|> "4" *> pure Four <|>+  "5" *> pure Five <|> "6" *> pure Six <|> "7" *> pure Seven <|> "8" *> pure Eight+++relation =+  "-3" *> pure IsolatedPosition <|> "-2" *> pure ObservingExaminedGame <|> "2"  *> pure Examiner <|>+  "-1" *> pure OponentsMove <|> "1"  *> pure MyMove <|> "0"  *> pure Observing+++column :: Parser Column+column =+  "0" *> pure A <|> "1" *> pure B <|>  "2" *> pure C <|> "3" *> pure D <|>+  "4" *> pure E <|> "5" *> pure F <|> "6" *> pure G <|> "7" *> pure H+++-- <b1> game 455 white [PP] black []++pieceHolding :: Parser FicsMessage+pieceHolding = "<b1>" *> pieceHoldingOnly++pieceHoldingOnly :: Parser FicsMessage+pieceHoldingOnly = PieceHolding+  <$> (" game " *> decimal <* " ")+  <*> ("white [" *> many' dropablePiece <* "] ")+  <*> ("black [" *> many' dropablePiece <* "]" <* option "" " <-")+++dropablePiece :: Parser PType+dropablePiece =+  "P" *> pure Pawn <|> "R" *> pure Rook <|> "N" *> pure Knight <|>+  "B" *> pure Bishop <|> "Q" *> pure Queen++
+ src/Macbeth/Fics/Parsers/Players.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.Players (+  finger,+  players,+  history,+  userHandle,+  partnerNotOpen,+  partnerOffer,+  partnerDeclined,+  partnerAccepted,+  players',+  player'+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Player+import Macbeth.Fics.Parsers.Api+import qualified Macbeth.Fics.Parsers.RatingParser as RP++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+++players :: Parser FicsMessage+players = Players <$> (commandHead 146 *> players')+++partnerNotOpen :: Parser FicsMessage+partnerNotOpen = PartnerNotOpen <$> (commandHead 84 *> userHandle <* " is not open for bughouse.")++partnerOffer :: Parser FicsMessage+partnerOffer = PartnerOffer <$> (userHandle <* " offers to be your bughouse partner")++partnerDeclined :: Parser FicsMessage+partnerDeclined = PartnerDeclined <$> (userHandle <* " declines the partnership request.")++partnerAccepted :: Parser FicsMessage+partnerAccepted = PartnerAccepted <$> (userHandle <* " agrees to be your partner.")++finger :: Parser FicsMessage+finger = Finger+  <$> (commandHead 37 *> "Finger of " *> userHandle <* ":")+  <*> manyTill anyChar "\ETB"+++history :: Parser FicsMessage+history = history' <|> emptyHistory+++history' :: Parser FicsMessage+history' = History+  <$> (commandHead 51 *> "\nHistory for " *> userHandle <* ":")+  <*> manyTill anyChar "\ETB"+++emptyHistory :: Parser FicsMessage+emptyHistory = do+  userHandle <- commandHead 51 *> userHandle <* " has no history games."+  return $ History userHandle (name userHandle ++ " has no history games.\n")+++players' :: Parser [Player]+players' = concat <$> sepBy (many' (player' <* many " ")) "\n"+++player' :: Parser Player+player' = Player+  <$> RP.rating+  <*> status'+  <*> userHandle+++status' :: Parser Status+status' =+  "^" *> pure InvolvedInAGame <|>+  "~" *> pure RunningASimulMatch <|>+  ":" *> pure NotOpenForMatch <|>+  "#" *> pure ExaminingAGame <|>+  "." *> pure InactiveOrBusy <|>+  " " *> pure NotBusy <|>+  "&" *> pure InvolvedInATournament+++userHandle :: Parser UserHandle+userHandle = UserHandle+  <$> many1' letter_ascii+  <*> option [] (many handleType')+++handleType' :: Parser HandleType+handleType' =+  "(*)" *> pure Admin <|>+  "(B)" *> pure Blindfold <|>+  "(C)" *> pure Computer <|>+  "(D)" *> pure NOT_DOCUMENTED <|>+  "(T)" *> pure Team <|>+  "(U)" *> pure Unregistered <|>+  "(CA)" *> pure ChessAdvisor <|>+  "(SR)" *> pure ServiceRepresentative <|>+  "(TD)" *> pure ServiceRepresentative <|>+  "(TM)" *> pure MamerManager <|>+  "(GM)" *> pure GrandMaster <|>+  "(IM)" *> pure InternationalMaster <|>+  "(FM)" *> pure FideMaster <|>+  "(WGM)" *> pure WomenGrandMaster <|>+  "(WIM)" *> pure WomenInternationalMaster <|>+  "(WFM)" *> pure WomenFideMaster+
+ src/Macbeth/Fics/Parsers/PositionParser.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.PositionParser (+  parsePosition+) where++import Macbeth.Fics.Api.Api+import Control.Arrow (second)+import Data.List.Split+import Data.Maybe+++parsePosition :: String -> [(Square, Piece)]+parsePosition str = fmap (second fromJust) $ filter (\(_,p) -> isJust p) squares+                where rows = parseRows str+                      squares = concat $ fmap parseSquares rows++parseRows :: String -> [(Row, String)]+parseRows str = zip rows lines+             where rows = [Eight, Seven .. One]+                   lines = splitOn " " str+++parseColumn :: String -> [(Column, Maybe Piece)]+parseColumn line = zip [A .. H] [readPiece c | c <- line]+++parseSquares :: (Row, String) -> [(Square, Maybe Piece)]+parseSquares (r, line) = fmap (\cc -> (Square (fst cc) r, snd cc)) (parseColumn line)+++readPiece :: Char -> Maybe Piece+readPiece 'P' = Just(Piece Pawn White)+readPiece 'R' = Just(Piece Rook White)+readPiece 'N' = Just(Piece Knight White)+readPiece 'B' = Just(Piece Bishop White)+readPiece 'Q' = Just(Piece Queen White)+readPiece 'K' = Just(Piece King White)+readPiece 'p' = Just(Piece Pawn Black)+readPiece 'r' = Just(Piece Rook Black)+readPiece 'n' = Just(Piece Knight Black)+readPiece 'b' = Just(Piece Bishop Black)+readPiece 'q' = Just(Piece Queen Black)+readPiece 'k' = Just(Piece King Black)+readPiece _ = Nothing
+ src/Macbeth/Fics/Parsers/RatingParser.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.RatingParser (+  rating+) where++import Macbeth.Fics.Api.Rating++import Control.Applicative+import Data.Attoparsec.ByteString.Char8++rating :: Parser Rating+rating = (Rating <$> decimal <*> pure None) <|> "++++" *> pure Guest <|> "----" *> pure Unrated
+ src/Macbeth/Fics/Parsers/SeekMsgParsers.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++module Macbeth.Fics.Parsers.SeekMsgParsers (+  clearSeek,+  newSeek,+  removeSeeks,+  seekNotAvailable+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Game+import Macbeth.Fics.Api.Rating+import Macbeth.Fics.Api.Seek+import Macbeth.Fics.Parsers.Api+import Macbeth.Fics.Utils.Bitmask++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+import Numeric++clearSeek :: Parser FicsMessage+clearSeek = "<sc>" *> pure ClearSeek++newSeek :: Parser FicsMessage+newSeek = NewSeek <$> seek'++removeSeeks :: Parser FicsMessage+removeSeeks = RemoveSeeks <$> ("<sr>" *> many1 (space *> decimal))++seekNotAvailable :: Parser FicsMessage+seekNotAvailable = commandHead 158 *> "That seek is not available." *> pure SeekNotAvailable++seek' :: Parser Seek+seek' = Seek+  <$> ("<s>" *> space *> decimal)+  <*> (space *> "w=" *> manyTill anyChar space)+  <*> ("ti=" *> titles')+  <*> ("rt=" *> rating')+  <*> (space *> "t=" *> decimal)+  <*> (space *> "i=" *> decimal)+  <*> (space *> "r=" *> ("r" *> pure True <|> "u" *> pure False))+  <*> (space *> "tp=" *> gameType')+  <*> (space *> "c=" *> ("W" *> pure (Just White) <|>+                         "B" *> pure (Just Black) <|>+                         "?" *> pure Nothing))+  <*> (space *> "rr=" *> ((,) <$> decimal <*> ("-" *> decimal)))++gameType' :: Parser GameType+gameType' =+  "blitz" *> pure Blitz <|>+  "lightning" *> pure Lightning <|>+  "untimed" *> pure Untimed <|>+  "examined" *> pure ExaminedGame <|>+  "standard" *> pure Standard <|>+  "wild/" *> decimal *> pure Wild <|>+  "atomic" *> pure Atomic <|>+  "crazyhouse" *> pure Crazyhouse <|>+  "bughouse" *> pure Bughouse <|>+  "losers" *> pure Losers <|>+  "suicide" *> pure Suicide <|>+  takeTill (== ' ') *> pure NonStandardGame+++rating' :: Parser Rating+rating' = Rating <$> decimal <*> provShow'+++provShow' :: Parser ProvShow+provShow' = " " *> pure None <|>+            "E" *> pure Estimated <|>+            "P" *> pure Provisional+++titles' :: Parser [Title]+titles' = manyTill anyChar space >>= pure . fromBitMask . fst . head . readHex
+ src/Macbeth/Fics/Utils/Bitmask.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DefaultSignatures #-}+module Macbeth.Fics.Utils.Bitmask (+  ToBitMask (..),+  fromBitMask,+  isInBitMask+) where++import Control.Monad+import Data.Bits+{-+  Thank you Nikita Volkov+  http://stackoverflow.com/questions/15910363/represent-a-list-of-enums-bitwise-as-an-int+-}+class ToBitMask a where+  toBitMask :: a -> Int+  -- | Using a DefaultSignatures extension to declare a default signature with+  -- an `Enum` constraint without affecting the constraints of the class itself.+  default toBitMask :: Enum a => a -> Int+  toBitMask = shiftL 1 . fromEnum++instance ( ToBitMask a ) => ToBitMask [a] where+  toBitMask = foldr (.|.) 0 . map toBitMask++-- | Not making this a typeclass, since it already generalizes over all+-- imaginable instances with help of `MonadPlus`.+fromBitMask ::+  ( MonadPlus m, Enum a, Bounded a, ToBitMask a ) =>+    Int -> m a+fromBitMask bm = msum $ map asInBM $ enumFrom minBound where+  asInBM a = if isInBitMask bm a then return a else mzero++isInBitMask :: ( ToBitMask a ) => Int -> a -> Bool+isInBitMask bm a = let aBM = toBitMask a in aBM == aBM .&. bm+
+ src/Macbeth/Utils/BoardUtils.hs view
@@ -0,0 +1,85 @@+module Macbeth.Utils.BoardUtils (+  drawArrow,+  squareToRect',+  toPos',+  pieceToBitmap+) where++import Macbeth.Fics.Api.Api+import Macbeth.Wx.PieceSet+import Paths++import Graphics.UI.WX+import System.FilePath+import System.IO.Unsafe+++rowToInt :: Macbeth.Fics.Api.Api.PColor -> Row -> Int+rowToInt White = abs . (7-) . fromEnum+rowToInt Black = fromEnum+++colToInt :: Macbeth.Fics.Api.Api.PColor -> Column -> Int+colToInt White = fromEnum+colToInt Black = abs . (7-) . fromEnum+++toPos' :: Int -> Square -> PColor -> Point+toPos' size (Square c r) color = point (colToInt color c * size) (rowToInt color r * size)+++squareToRect' :: Int -> Square -> PColor -> Rect+squareToRect' size sq color = Rect pointX' pointY' size size+  where pointX' = pointX $ toPos' size sq color+        pointY' = pointY $ toPos' size sq color+++drawArrow dc size s1 s2 perspective =+  drawArrowPt dc (pt (x1+size_half) (y1+size_half)) (pt (x2'+size_half) (y2'+size_half))+    where (Rect x1 y1 _ _ ) = squareToRect' size s1 perspective+          (Rect x2 y2 _ _ ) = squareToRect' size s2 perspective+          size_half = round $ fromIntegral size / 2+          x2'+             | x2 > x1 = x2 - size_half+             | x2 < x1 = x2 + size_half+             | otherwise = x2+          y2'+             | y2 > y1 = y2 - size_half+             | y2 < y1 = y2 + size_half+             | otherwise = y2++drawArrowPt dc p1 p2 = do+  line dc p1 p2 []+  polygon dc (fmap (movePt (pointX p2) (pointY p2) . rotate (dfix-90)) triangle) []+  where+    triangle = [(0, 0), (-2, -7), (2, -7)]+    movePt x y (Point px py) = pt (x + px) (y + py)+    deltaX = pointX p2 - pointX p1+    deltaY = pointY p2 - pointY p1+    d = atan(fromIntegral deltaY / fromIntegral deltaX) * 180 / pi+    dfix = if deltaX < 0 then d -180 else d+++rotate :: Double -> (Int, Int) -> Point+rotate d ptx = pt (round $ x * cos rad - y * sin rad) (round $ x * sin rad + y * cos rad)+  where x = fromIntegral $ fst ptx+        y = fromIntegral $ snd ptx+        rad = d/180*pi+++pieceToBitmap :: Int -> PieceSet -> Piece -> Bitmap ()+pieceToBitmap size pieceSet p = bitmap $ unsafePerformIO $ getDataFileName $ path pieceSet </> show size </> pieceToFile p ++ ".png"+  where+    pieceToFile :: Piece -> String+    pieceToFile (Piece King Black) = "bk"+    pieceToFile (Piece Queen Black) = "bq"+    pieceToFile (Piece Rook Black) = "br"+    pieceToFile (Piece Knight Black) = "bn"+    pieceToFile (Piece Bishop Black) = "bb"+    pieceToFile (Piece Pawn Black) = "bp"+    pieceToFile (Piece King White) = "wk"+    pieceToFile (Piece Queen White) = "wq"+    pieceToFile (Piece Rook White) = "wr"+    pieceToFile (Piece Knight White) = "wn"+    pieceToFile (Piece Bishop White) = "wb"+    pieceToFile (Piece Pawn White) = "wp"
+ src/Macbeth/Utils/FEN.hs view
@@ -0,0 +1,54 @@+module Macbeth.Utils.FEN (+  available,+  convert+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Move++import Data.List.Utils+++convert :: Move -> String+convert m = piecePlacement (positionRaw m) ++ " " +++        activeColor (turn m) ++ " " +++        castlingAv' (castlingAv m) ++ " " +++        enPassant (turn m) (doublePawnPush m) ++ " " +++        show (ply m) ++ " " +++        show (moveNumber m)++available :: Move -> Bool+available m+  | moveNumber m == 1 && turn m == Black = False+  | otherwise = True++enPassant :: PColor -> Maybe Column -> String+enPassant Black (Just c) = show $ Square c Three+enPassant White (Just c) = show $ Square c Six+enPassant _ _ = "-"+++castlingAv' :: [Castling] -> String+castlingAv' [] = "-"+castlingAv' cx = concat $ fmap castlingToStr cx+++castlingToStr WhiteLong = "Q"+castlingToStr WhiteShort = "K"+castlingToStr BlackLong = "q"+castlingToStr BlackShort = "k"+++activeColor :: PColor -> String+activeColor White = "w"+activeColor Black = "b"+++piecePlacement :: String -> String+piecePlacement = replace " " "/" . emptySquares 8+++emptySquares :: Int -> String -> String+emptySquares num str+  | num == 0 = str+  | otherwise = emptySquares (num-1)  (replace (replicate num '-') (show num) str)
+ src/Macbeth/Utils/PGN.hs view
@@ -0,0 +1,66 @@+module Macbeth.Utils.PGN (+  saveAsPGN+) where++import Macbeth.Fics.Configuration+import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Move+import Macbeth.Fics.Api.Game (GameResult)+import qualified Macbeth.Utils.FEN as FEN+import Macbeth.Wx.BoardState++import Control.Monad+import Data.Maybe+import Data.Time+import System.FilePath+++saveAsPGN :: BoardState ->  IO ()+saveAsPGN b = saveAsPGN' (reverse $ moves b) (gameResult b)++saveAsPGN' :: [Move] -> Maybe GameResult -> IO ()+saveAsPGN' [] _ = return ()+saveAsPGN' moves mGameResult = do+  dateTime <- getZonedTime+  appDir <- directory `fmap` loadConfig+  when (isJust appDir) $ do+    path <- filepath (fromJust appDir) dateTime (head moves)+    appendFile path $ toPGN (filter (isJust . movePretty) moves) mGameResult dateTime++filepath :: FilePath -> ZonedTime -> Move -> IO FilePath+filepath appDir dateTime m = return $ appDir </>+  formatTime Data.Time.defaultTimeLocale "%Y-%m-%d_%H-%M-%S_" dateTime ++ nameW m ++ "_vs_" ++ nameB m ++ ".pgn"++toPGN :: [Move] -> Maybe GameResult -> ZonedTime -> String+toPGN [] _ _ = ""+toPGN moves@(m:_) mGameResult dateTime =+  tagsSection m mGameResult dateTime ++ "\n\n" +++  moveSection (if FEN.available $ head moves then tail moves else moves) +++  " " ++ maybe "" show mGameResult ++ "\n\n"++moveSection :: [Move] -> String+moveSection = unwords . fmap (toString . toSAN)++tagsSection :: Move -> Maybe GameResult -> ZonedTime -> String+tagsSection m mGameResult dateTime =+  "[Event \"?\"]\n\+  \[Site \"?\"]\n\+  \[Date \"" ++ formatTime Data.Time.defaultTimeLocale "%Y.%m.%d" dateTime ++ "\"]\n\+  \[Time \"" ++ formatTime Data.Time.defaultTimeLocale "%T" dateTime ++ "\"]\n\+  \[Round \"?\"]\n\+  \[White \"" ++ nameW m ++ "\"]\n\+  \[Black \"" ++ nameB m ++ "\"]\n\+  \[Result \"" ++ maybe "?" show mGameResult ++ "\"]\n\+  \[BlackElo \"?\"]\n\+  \[WhiteElo \"?\"]\n\+  \[ECO \"?\"]\n\+  \[TimeControl \"?\"]\n\+  \[SetUp \"" ++ (if FEN.available m then "1" else "?") ++ "\"]\n\+  \[FEN \"" ++ (if FEN.available m then FEN.convert m else "?") ++ "\"]\n"++toSAN :: Move -> (Int, PColor, String)+toSAN m = (moveNumber m, turn m, fromJust $ movePretty m)++toString :: (Int, PColor, String) -> String+toString (num, Black, move) = show num ++ "." ++ move+toString (_, White, move) = move
+ src/Macbeth/Utils/Utils.hs view
@@ -0,0 +1,22 @@+module Macbeth.Utils.Utils (+  formatTime+) where++import Control.Monad.State++formatTime :: Int -> String+formatTime seconds = show h ++ " : " ++ format m ++ " : " ++ format s+  where+    (_, (h,m,s)) = runState (calc seconds) (0,0,0)+++calc :: Int -> State (Int, Int, Int) Int+calc seconds+  | seconds >= 3600 = get >>= \(h, m, s) -> put (h+1, m, s) >> calc (seconds - 3600)+  | seconds >= 60 = get >>= \(h, m, s) -> put (h, m+1, s) >> calc (seconds - 60)+  | otherwise = get >>= \(h, m, _) -> put (h, m, max 0 seconds) >> return 0++format :: Int -> String+format i+  | i < 10 = "0" ++ show i+  | otherwise = show i
+ src/Macbeth/Wx/Board.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE LambdaCase #-}++module Macbeth.Wx.Board (+  draw,+  onMouseEvent+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Move+import Macbeth.Utils.BoardUtils+import Macbeth.Wx.BoardState++import Control.Monad.Reader+import Control.Monad.Trans.Maybe+import Data.Maybe+import Control.Concurrent.STM+import Graphics.UI.WX hiding (position, update, resize, when)+import Graphics.UI.WXCore hiding (Row, Column, when)+import System.IO++type BoardT a = ReaderT (DC a, BoardState) IO ()++draw :: TVar BoardState -> DC a -> t -> IO ()+draw vState dc _ = do+  state <- readTVarIO vState+  flip runReaderT (dc, state) $ do+    setScale+    drawBoard+    drawHighlightLastMove+    drawHighlightPreMove+    drawPieces+    drawSelectedSquare+    drawDraggedPiece+++setScale :: BoardT a+setScale = do+  (dc, state) <- ask+  liftIO $ dcSetUserScale dc (scale state) (scale state)+++drawBoard :: BoardT a+drawBoard = do+  (dc, state) <- ask+  let perspective' = perspective state+  let bw = concat $ replicate 4 (concat $ replicate 4 seed ++ replicate 4 (reverse seed))+       where seed = if perspective' == White then [Black, White] else [White, Black]+  let sq = [Square c r  | c <- [A .. H], r <- [One .. Eight]]+  lift $ set dc [ pen := penTransparent ]+  lift $ withBrushStyle (BrushStyle BrushSolid (rgb (180::Int) 150 100)) $ \blackBrush ->+    withBrushStyle (BrushStyle BrushSolid white) $ \whiteBrush ->+      mapM_ (\(c,sq) -> do+        dcSetBrush dc $ if c == White then whiteBrush else blackBrush+        paintSquare dc state sq)+          (zip (if perspective' == White then bw else reverse bw) sq)+++drawHighlightLastMove :: BoardT a+drawHighlightLastMove = do+  (dc, state) <- ask+  liftIO $ when (isHighlightMove $ lastMove state) $+    sequence_ $ paintHighlight dc state blue `fmap` pieceMove state+  where+    isHighlightMove :: Move -> Bool+    isHighlightMove m = (isJust . moveVerbose) m && (wasOponentMove m || relation m == Observing)+++drawHighlightPreMove :: BoardT a+drawHighlightPreMove = do+  (dc, state) <- ask+  liftIO $ sequence_ $ paintHighlight dc state yellow `fmap` preMoves state+++drawPieces :: BoardT a+drawPieces = do+  (dc, state) <- ask+  liftIO $ sequence_ $ drawPiece dc state `fmap` _position state+  where+    drawPiece :: DC a -> BoardState -> (Square, Piece) -> IO ()+    drawPiece dc state (sq, p) = drawBitmap dc+      (pieceToBitmap (psize state) (pieceSet state) p)+      (toPos' (psize state) sq (perspective state)) True []+++drawSelectedSquare :: BoardT a+drawSelectedSquare = do+  (dc, state) <- ask+  liftIO $ when (isGameUser (lastMove state) && isNothing (gameResult state)) $+    withBrushStyle brushTransparent $ \transparent -> do+      dcSetBrush dc transparent+      set dc [pen := penColored red 1]+      paintSquare dc state (getSelectedSquare state)+++drawDraggedPiece :: BoardT a+drawDraggedPiece = do+  (dc, state) <- ask+  case draggedPiece state of+    Just dp -> liftIO $ drawDraggedPiece'' state dc dp+    _ -> return ()+++drawDraggedPiece'' :: BoardState -> DC a -> DraggedPiece -> IO ()+drawDraggedPiece'' state dc (DraggedPiece pt piece _) = drawBitmap dc (pieceToBitmap size (pieceSet state) piece) (scalePoint pt) True []+  where+    scale' = scale state+    size = psize state+    scalePoint pt = point (scaleValue $ pointX pt) (scaleValue $ pointY pt)+    scaleValue value = round $ (fromIntegral value - fromIntegral size / 2 * scale') / scale'+++paintHighlight :: DC a -> BoardState -> Color -> PieceMove -> IO ()+paintHighlight dc state color (PieceMove _ s1 s2) = do+  set dc [pen := penColored color 1]+  withBrushStyle (BrushStyle (BrushHatch HatchBDiagonal) color) $ \brushBg -> do+    dcSetBrush dc brushBg+    mapM_ (paintSquare dc state) [s1, s2]+  withBrushStyle (BrushStyle BrushSolid color) $ \brushArrow -> do+    dcSetBrush dc brushArrow+    drawArrow dc (psize state) s1 s2 (perspective state)+paintHighlight dc state color (DropMove _ s1) = do+  set dc [pen := penColored color 1]+  withBrushStyle (BrushStyle (BrushHatch HatchBDiagonal) color) $ \brushBg -> do+    dcSetBrush dc brushBg+    paintSquare dc state s1+++paintSquare :: DC a -> BoardState -> Square -> IO ()+paintSquare dc state sq = drawRect dc (squareToRect' (psize state) sq (perspective state)) []+++onMouseEvent :: Handle -> Var BoardState -> EventMouse -> IO ()+onMouseEvent h vState = \case++    MouseMotion pt _ -> updateMousePosition vState pt++    MouseLeftDown pt _ -> do+      dp <- draggedPiece `fmap` readTVarIO vState+      if isJust dp then dropDraggedPiece vState h pt else pickUpPiece vState pt++    MouseLeftUp click_pt _ -> dropDraggedPiece vState h click_pt++    MouseLeftDrag pt _ -> updateMousePosition vState pt++    _ -> return ()+++updateMousePosition :: TVar BoardState -> Point -> IO ()+updateMousePosition vState pt = atomically $ modifyTVar vState+  (\s -> s{ mousePt = pt, draggedPiece = draggedPiece s >>= setNewPoint pt})+  where+    setNewPoint :: Point -> DraggedPiece -> Maybe DraggedPiece+    setNewPoint pt (DraggedPiece _ p o) = Just (DraggedPiece pt p o)+++dropDraggedPiece :: TVar BoardState -> Handle -> Point -> IO ()+dropDraggedPiece vState h click_pt = do+  state <- readTVarIO vState+  void $ runMaybeT $ do+      dp <- MaybeT $ return (draggedPiece state)+      let pieceMove = toPieceMove (pointToSquare state click_pt) dp+      let newPosition = movePiece pieceMove (_position state)+      liftIO $ do+        varSet vState state { _position = newPosition, draggedPiece = Nothing}+        if isWaiting state+          then hPutStrLn h $ "6 " ++ show pieceMove+          else addPreMove vState pieceMove+  where+    toPieceMove :: Square -> DraggedPiece -> PieceMove+    toPieceMove toSq (DraggedPiece _ piece (FromBoard fromSq)) = PieceMove piece fromSq toSq+    toPieceMove toSq (DraggedPiece _ piece FromHolding) = DropMove piece toSq++    addPreMove :: TVar BoardState -> PieceMove -> IO ()+    addPreMove vState pm = atomically $ modifyTVar vState (\s -> s {preMoves = preMoves s ++ [pm]})+++pickUpPiece :: TVar BoardState -> Point -> IO ()+pickUpPiece vState pt = do+  state <- readTVarIO vState+  let square' = pointToSquare state pt+  case getPiece (_position state) square' (colorUser $ lastMove state) of+     Just piece -> varSet vState state { _position = removePiece (_position state) square'+                                          , draggedPiece = Just $ DraggedPiece pt piece $ FromBoard square'}+     _ -> return ()+  where+    removePiece :: Position -> Square -> Position+    removePiece pos sq = filter (\(sq', _) -> sq /= sq') pos++    getPiece :: Position -> Square -> PColor -> Maybe Piece+    getPiece pos sq color = sq `lookup` pos >>= checkColor color+      where+        checkColor :: PColor -> Piece -> Maybe Piece+        checkColor c p@(Piece _ c') = if c == c' then Just p else Nothing+
+ src/Macbeth/Wx/BoardState.hs view
@@ -0,0 +1,222 @@+module Macbeth.Wx.BoardState (+  BoardState(..),+  DraggedPiece(..),+  Origin(..),+  PieceMove (..),++  pickUpPieceFromHolding,+  discardDraggedPiece,++  setPromotion,+  togglePromotion,++  pointToSquare,+  movePiece,++  update,+  setResult,+  resize,+  invertPerspective,++  performPreMoves,+  cancelLastPreMove,++  setPieceSet,+  getPieceHolding,++  getSelectedSquare,+  initBoardState+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Move+import Macbeth.Fics.Api.Game+import Macbeth.Wx.PieceSet++import Control.Monad+import Control.Concurrent.STM+import Data.Maybe+import Data.List+import Graphics.UI.WX hiding (position, update, resize, when)+import Safe+import System.IO+++data BoardState = BoardState {+    lastMove :: Move+  , gameResult :: Maybe GameResult+  , pieceMove :: [PieceMove]+  , moves :: [Move]+  , _position :: Position+  , preMoves :: [PieceMove]+  , perspective :: PColor+  , mousePt :: Point+  , promotion :: PType+  , draggedPiece :: Maybe DraggedPiece+  , isWaiting :: Bool+  , psize :: Int+  , scale :: Double+  , pieceSet :: PieceSet+  , phW :: [PType]+  , phB :: [PType] }+++data DraggedPiece = DraggedPiece Point Piece Origin deriving (Show)++data Origin = FromHolding | FromBoard Square deriving (Show)++data PieceMove = PieceMove { piece :: Piece, from :: Square, to :: Square } | DropMove Piece Square++instance Show PieceMove where+  show (PieceMove _ s1 s2) = show s1 ++ show s2+  show (DropMove (Piece p _) s) = show p ++ "@" ++ show s+++pickUpPieceFromHolding :: TVar BoardState -> PType -> IO ()+pickUpPieceFromHolding vState p = atomically $ modifyTVar vState+  (\s -> let color = colorUser (lastMove s)+             isAllowed = isGameUser (lastMove s) && p `elem` getPieceHolding color s+         in if isAllowed+            then s{draggedPiece = Just $ DraggedPiece (mousePt s) (Piece p color) FromHolding }+            else s)+++discardDraggedPiece :: TVar BoardState -> IO ()+discardDraggedPiece vState = atomically $ modifyTVar vState (\s -> s {+    draggedPiece = Nothing+  , _position = movePieces (preMoves s) (position $ lastMove s)})+++invertPerspective :: TVar BoardState -> IO ()+invertPerspective vState = atomically $ modifyTVar vState (\s -> s{perspective = invert $ perspective s})+++setResult :: TVar BoardState -> GameResult -> IO ()+setResult vState r = atomically $ modifyTVar vState (\s -> s{+     gameResult = Just r+   , _position = position $ lastMove s+   , preMoves = []+   , draggedPiece = Nothing})+++setPromotion :: PType -> TVar BoardState -> IO ()+setPromotion p vState = atomically $ modifyTVar vState (\s -> s{promotion = p})+++togglePromotion :: TVar BoardState -> IO PType+togglePromotion vState = atomically $ do+  modifyTVar vState (\s -> s{promotion = togglePromotion' (promotion s)})+  promotion `fmap` readTVar vState+  where+    togglePromotion' :: PType -> PType+    togglePromotion' p = let px = [Queen, Rook, Knight, Bishop]+                         in px !! ((fromJust (p `elemIndex` px) + 1) `mod` length px)+++update :: TVar BoardState -> Move -> MoveModifier -> IO ()+update vBoardState move ctx = atomically $ modifyTVar vBoardState (\s -> s {+    isWaiting = isNextMoveUser move+  , pieceMove = diffPosition (position $ lastMove s) (position move)+  , moves = addtoHistory move ctx (moves s)+  , lastMove = move+  , _position = movePieces (preMoves s) (position move)})+++diffPosition :: Position -> Position -> [PieceMove]+diffPosition before after =+  let from = before \\ after+      to = after \\ before+  in [PieceMove piece1 s1 s2 | (s1, piece1) <- from, (s2, piece2) <- to, piece1 == piece2, s1 /= s2 ]+++addtoHistory :: Move -> MoveModifier -> [Move] -> [Move]+addtoHistory _ Illegal mx = mx+addtoHistory m (Takeback _) mx = m : tail (dropWhile (not . equal m) mx)+  where+    equal :: Move -> Move -> Bool+    equal m1 m2 = (moveNumber m1 == moveNumber m2) && (turn m1 == turn m2)+addtoHistory m _ mx = m : mx+++resize :: Panel () -> TVar BoardState -> IO ()+resize p vState = do+  (Size x _) <- get p size+  let psize' = pieceSetFindSize x+  atomically $ modifyTVar vState (\s -> s { psize = psize', scale = fromIntegral x / 8 / fromIntegral psize'})+++cancelLastPreMove :: TVar BoardState -> IO ()+cancelLastPreMove vBoardState = atomically $ modifyTVar vBoardState (\s ->+  let preMoves' = fromMaybe [] $ initMay (preMoves s) in s {+      preMoves = preMoves'+    , _position = movePieces preMoves' (position $ lastMove s)})+++performPreMoves :: TVar BoardState -> Handle -> IO ()+performPreMoves vBoardState h = do+  preMoves' <- preMoves `fmap` readTVarIO vBoardState+  unless (null preMoves') $ do+    atomically $ modifyTVar vBoardState (\s -> s {+      isWaiting = False,+      preMoves = tail preMoves'})+    hPutStrLn h $ "6 " ++ show (head preMoves' )+++setPieceSet :: TVar BoardState -> PieceSet -> IO ()+setPieceSet vState ps = atomically (modifyTVar vState (\s -> s { pieceSet = ps }))+++getPieceHolding :: PColor -> BoardState -> [PType]+getPieceHolding White bs = phW bs+getPieceHolding Black bs = phB bs+++getSelectedSquare :: BoardState -> Square+getSelectedSquare state = pointToSquare state (mousePt state)+++pointToSquare :: BoardState -> Point -> Square+pointToSquare state (Point x y) = Square+  (intToCol (perspective state) (floor $ fromIntegral x / fieldSize state))+  (intToRow (perspective state) (floor $ fromIntegral y / fieldSize state))+  where+    intToRow :: PColor -> Int -> Row+    intToRow White = toEnum . abs . (7-)+    intToRow Black = toEnum++    intToCol :: PColor -> Int -> Column+    intToCol White = toEnum+    intToCol Black = toEnum . abs . (7-)++    fieldSize :: BoardState -> Double+    fieldSize bs = scale bs * fromIntegral (psize bs)+++movePieces :: [PieceMove] -> Position -> Position+movePieces moves pos = foldl (flip movePiece) pos moves+++movePiece :: PieceMove -> Position -> Position+movePiece (PieceMove piece from to) position = filter (\(s, _) -> s /= from && s /= to) position ++ [(to, piece)]+movePiece (DropMove piece sq) pos = filter (\(s, _) -> s /= sq) pos ++ [(sq, piece)]+++initBoardState :: Move -> BoardState+initBoardState move = BoardState {+    lastMove = move+  , gameResult = Nothing+  , pieceMove = []+  , moves = [move] -- ^ accept empty positions, filter when creating pgn+  , _position = Macbeth.Fics.Api.Move.position move+  , preMoves = []+  , perspective = if relation move == Observing then White else colorUser move+  , mousePt = Point 0 0+  , promotion = Queen+  , draggedPiece = Nothing+  , isWaiting = relation move == MyMove+  , psize = 40+  , scale = 1.0+  , pieceSet = head pieceSets+  , phW = []+  , phB = []}+
+ src/Macbeth/Wx/Challenge.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE LambdaCase #-}++module Macbeth.Wx.Challenge (+  wxChallenge+) where++import Macbeth.Fics.Api.Challenge+import Macbeth.Fics.FicsMessage+import Macbeth.Wx.Utils++import Control.Concurrent+import Graphics.UI.WX+import Graphics.UI.WXCore+import System.IO+++wxChallenge :: Handle -> Challenge -> Chan FicsMessage  -> IO ()+wxChallenge h c chan = do+  vCmd <- newEmptyMVar++  f <- frame []+  p <- panel f []++  b_accept  <- button p [text := "Accept", on command := hPutStrLn h "5 accept" >> close f]+  b_decline <- button p [text := "Decline", on command := hPutStrLn h "5 decline" >> close f]+  st_params <- staticText p [ text := displayChallenge c+                            , fontFace := "Avenir Next Medium"+                            , fontSize := 16+                            , fontWeight := WeightBold]++  set f [ defaultButton := b_accept+        , layout := container p $ margin 10 $+            column 5 [boxed "You received a challenge." (+              grid 5 5 [+                [ hfill $ widget st_params]]+            )+            , floatBottomRight $ row 5 [widget b_accept, widget b_decline]]+        ]++  evtHandlerOnMenuCommand f eventId $ takeMVar vCmd >>= \case++      MatchRequested c' -> when (isUpdate c c') $ close f++      WxClose -> close f++      _ -> return ()++  threadId <- forkIO $ eventLoop eventId chan vCmd f+  windowOnDestroy f $ killThread threadId+++isUpdate :: Challenge -> Challenge -> Bool+isUpdate c c' = (nameW c == nameW c') && (nameB c == nameB c')++eventId = wxID_HIGHEST + 1
+ src/Macbeth/Wx/Configuration.hs view
@@ -0,0 +1,56 @@+module Macbeth.Wx.Configuration (+  wxConfiguration+) where++import Macbeth.Fics.Configuration+import Macbeth.Fics.FicsMessage+import Macbeth.Wx.Utils++import Control.Concurrent.Chan+import Control.Monad+import Control.Monad.Except+import Graphics.UI.WX+import Graphics.UI.WXCore++import qualified Data.ByteString.Char8 as BS+import qualified Data.Yaml as Y++wxConfiguration :: Chan FicsMessage -> IO ()+wxConfiguration chan = do+  f  <- frame [ text := "Macbeth"]+  ct <- textCtrlEx f (wxTE_MULTILINE .+. wxTE_RICH) [font := fontFixed]+  showConfig ct loadConfig+  status <- statusField []++  b_default <- button f [text := "Default", on command := showConfig ct loadDefaultConfig]+  b_current <- button f [text := "Current", on command := showConfig ct loadConfig]+  b_save <- button f [ text := "Save",+                       on command := void $ runExceptT $ parseAndSave ct status `catchError` showError status]+++  set f [ statusBar := [status],+          layout := margin 10 $ column 10 [+                       boxed "Configuration" $ fill $ minsize (Size 380 220) $ widget ct+                     , hfloatRight $ row 5 [widget b_default, widget b_current, widget b_save]]+        ]+  registerWxCloseEventListener f chan++showConfig :: TextCtrl() -> IO Config -> IO ()+showConfig ct io_config = io_config >>= \config -> set ct [text := comments ++ BS.unpack (Y.encode config)]+++parseAndSave :: TextCtrl () -> StatusField -> ExceptT Y.ParseException IO ()+parseAndSave ct status = do+  config <- ExceptT $ (Y.decodeEither' . BS.pack) `fmap` get ct text+  liftIO $ saveConfig config+  liftIO $ set status [text := "Configuration saved."]+++showError :: StatusField -> Y.ParseException -> ExceptT Y.ParseException IO ()+showError status _ = liftIO $ set status [text := "Illegal file format."]+++comments :: String+comments = "# Changes will take effect only after restart (for now).\n\n\+           \# If you change the directory make sure it exists.\n\+           \# It will not be created for you.\n\n"
+ src/Macbeth/Wx/Finger.hs view
@@ -0,0 +1,30 @@+module Macbeth.Wx.Finger (+  wxInfo+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Player+import Macbeth.Wx.Utils++import Control.Concurrent.Chan+import Graphics.UI.WX++wxInfo :: FicsMessage -> Chan FicsMessage -> IO ()+wxInfo msg chan = do+  f <- frameFixed [ text := title msg]+  st <- staticText f [ text := showAll msg+                     , font := fontFixed+                     , fontSize := 14]+  set f [layout := margin 10 $ row 0 [widget st]]+  registerWxCloseEventListener f chan++title :: FicsMessage -> String+title (Finger userHandle _) = "Finger of " ++ name userHandle+title (History userHandle _) = "History for " ++ name userHandle+title _ = ""+++showAll :: FicsMessage -> String+showAll m@(Finger _ msg) = title m ++ msg+showAll m@(History _ msg) = title m ++ "\n" ++ msg+showAll _ = ""
+ src/Macbeth/Wx/Game.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Macbeth.Wx.Game (+  wxGame+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.FicsMessage hiding (gameId, Observing)+import Macbeth.Fics.Api.Move+import Macbeth.Utils.PGN+import qualified Macbeth.Wx.BoardState as Api+import Macbeth.Wx.Utils+import Macbeth.Wx.PieceSet+import Macbeth.Wx.StatusPanel+import qualified Macbeth.Wx.Board as Board++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Data.Maybe+import Graphics.UI.WX hiding (when, position)+import Graphics.UI.WXCore hiding (when, Timer)+import System.IO++eventId = wxID_HIGHEST + 1++wxGame :: Handle -> Move -> Chan FicsMessage -> IO ()+wxGame h move chan = do+  vCmd <- newEmptyMVar+  f <- frame [ text := "[Game " ++ show (gameId move) ++ "] " ++ nameW move ++ " vs " ++ nameB move]+  p_back <- panel f []++  -- board+  let boardState = Api.initBoardState move+  vBoardState <- newTVarIO boardState+  p_board <- panel p_back [ on paint := Board.draw vBoardState]++  -- player panels+  (p_white, updateClockW) <- createStatusPanel p_back White vBoardState+  (p_black, updateClockB) <- createStatusPanel p_back Black vBoardState++  -- layout helper+  let updateBoardLayoutIO = updateBoardLayout p_back p_board p_white p_black vBoardState >> refit f+  updateBoardLayoutIO++  -- status line+  status <- statusField []+  promotion <- statusField [ statusWidth := 30, text := "=" ++ show (Api.promotion boardState)]++  -- context menu+  ctxMenu <- menuPane []+  menuItem ctxMenu [ text := "Turn board", on command :=+    Api.invertPerspective vBoardState >> updateBoardLayoutIO >> repaint p_board >> resizeFrame f vBoardState p_board]+  when (isGameUser move) $ do+     menuLine ctxMenu+     menuItem ctxMenu [ text := "Request takeback 1", on command := hPutStrLn h "4 takeback 1"]+     menuItem ctxMenu [ text := "Request takeback 2", on command := hPutStrLn h "4 takeback 2"]+     menuItem ctxMenu [ text := "Request abort", on command := hPutStrLn h "4 abort"]+     menuItem ctxMenu [ text := "Offer draw", on command := hPutStrLn h "4 draw" ]+     menuItem ctxMenu [ text := "Resign", on command := hPutStrLn h "4 resign" ]+     windowOnMouse p_board True (\pt -> Board.onMouseEvent h vBoardState pt >> repaint p_board)+  menuLine ctxMenu+  wxPieceSetsMenu ctxMenu vBoardState p_board++  set p_board [ on clickRight := (\pt -> menuPopup ctxMenu pt p_board) ]++  -- key handler+  windowOnKeyDown p_board $ onKeyDownHandler h p_board f vBoardState promotion+  windowOnKeyUp p_board $ onKeyUpHandler vBoardState h promotion++  --set layout+  set f [ statusBar := [status] ++ [promotion | isGameUser move]+        , layout := fill $ widget p_back+        , on resize := resizeFrame f vBoardState p_board]++  -- necessary: after GameResult no more events are handled+  tiClose <- dupChan chan >>= registerWxCloseEventListenerWithThreadId f++  threadId <- forkIO $ eventLoop eventId chan vCmd f+  evtHandlerOnMenuCommand f eventId $ takeMVar vCmd >>= \cmd ->+    updateClockW cmd >> updateClockB cmd >> case cmd of++    GameMove ctx move' -> when (gameId move' == gameId move) $ do+      set status [text := show ctx]+      Api.update vBoardState move' ctx+      when (isNextMoveUser move') $ Api.performPreMoves vBoardState h+      repaint p_board++    GameResult id reason result -> when (id == gameId move) $ do+      set status [text := (show result ++ " " ++ reason)]+      Api.setResult vBoardState result+      repaint p_board+      hPutStrLn h "4 iset seekinfo 1"+      killThread threadId++    DrawRequest -> set status [text := nameOponent move ++ " offered a draw. Accept? (y/n)"]++    DrawRequestDeclined user -> set status [text := user ++ " declines the draw request."]++    AbortRequest user -> set status [text := user ++ " would like to abort the game. Accept? (y/n)"]++    AbortRequestDeclined user -> set status [text := user ++ " declines the abort request."]++    TakebackRequest user numTakeback -> set status [text := user ++ " would like to take back " ++ show numTakeback ++ " half move(s). Accept? (y/n)"]++    PromotionPiece p -> Api.setPromotion p vBoardState >> set promotion [text := "=" ++ show p]++    _ -> return ()++  windowOnDestroy f $ do+    sequence_ $ fmap (handle (\(_ :: IOException) -> return ()) . killThread) [threadId, tiClose]+    boardState <- readTVarIO vBoardState+    when (isGameUser move) $ saveAsPGN boardState+    unless (isJust $ Api.gameResult boardState) $ case relation move of+      MyMove -> hPutStrLn h "5 resign"+      OponentsMove -> hPutStrLn h "5 resign"+      Observing -> hPutStrLn h $ "5 unobserve " ++ show (gameId move)+      _ -> return ()+++resizeFrame :: Frame () -> TVar Api.BoardState -> Panel() -> IO ()+resizeFrame f vBoardState p_board = do+  (Size w h) <- windowGetClientSize f+  Api.resize p_board vBoardState+  let x = max w (h-66)+  windowSetClientSize f $ Size x (x+66)+  void $ windowLayout f+++updateBoardLayout :: Panel() -> Panel() -> Panel() -> Panel() -> TVar Api.BoardState -> IO ()+updateBoardLayout pback board white black vBoardState = do+  state <- readTVarIO vBoardState+  set pback [ layout := column 0 [ hfill $ widget (if Api.perspective state == White then black else white)+                                 , stretch $ minsize (Size 320 320) $ shaped $ widget board+                                 , hfill $ widget (if Api.perspective state == White then white else black)]]+++wxPieceSetsMenu :: Menu () -> TVar Api.BoardState -> Panel () -> IO ()+wxPieceSetsMenu ctxMenu vState p = do+  sub <- menuPane [text := "Piece Sets"]+  mapM_ (\ps -> menuItem sub [ text := display ps, on command := Api.setPieceSet vState ps >> repaint p ]) pieceSets+  void $ menuSub ctxMenu sub [ text := "Piece Sets" ]+++onKeyDownHandler :: Handle -> Panel () -> Frame () -> TVar Api.BoardState -> StatusField -> EventKey -> IO ()+onKeyDownHandler h p_board f vBoardState sf evt+    | onlyKey evt 'X' = do Api.cancelLastPreMove vBoardState; repaint p_board++    | onlyKey evt 'Q' = do Api.pickUpPieceFromHolding vBoardState Queen; repaint p_board+    | onlyKey evt 'B' = do Api.pickUpPieceFromHolding vBoardState Bishop; repaint p_board+    | onlyKey evt 'K' = do Api.pickUpPieceFromHolding vBoardState Knight; repaint p_board+    | onlyKey evt 'R' = do Api.pickUpPieceFromHolding vBoardState Rook; repaint p_board+    | onlyKey evt 'P' = do Api.pickUpPieceFromHolding vBoardState Pawn; repaint p_board+    | (keyKey evt == KeyEscape) && isNoneDown (keyModifiers evt) = do Api.discardDraggedPiece vBoardState; repaint p_board++    | onlyKey evt 'N' = hPutStrLn h "5 decline"+    | onlyKey evt 'Y' = hPutStrLn h "5 accept"++    | keyWithMod evt 'W' justControl = close f+    | keyWithMod evt 'O' justControl = Api.togglePromotion vBoardState >>= \p -> set sf [text := "=" ++ show p]+    | otherwise = return ()+    where onlyKey evt c = (keyKey evt == KeyChar c) && isNoneDown (keyModifiers evt)+          keyWithMod evt c mod = (keyKey evt == KeyChar c) && (keyModifiers evt == mod)+++onKeyUpHandler :: TVar Api.BoardState -> Handle -> StatusField -> EventKey -> IO ()+onKeyUpHandler vBoardState h sf evt+  | (keyKey evt == KeyControl) && isNoneDown (keyModifiers evt) =+      Api.promotion `fmap` readTVarIO vBoardState >>= \p -> do+        hPutStrLn h $ "5 promote " ++ show p+        set sf [text := "=" ]+  | otherwise = return ()+
+ src/Macbeth/Wx/GameMoves.hs view
@@ -0,0 +1,83 @@+module Macbeth.Wx.GameMoves (+  wxGameMoves+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Move++import Control.Concurrent.STM+import Control.Monad+import Data.Maybe+import Graphics.UI.WX+import Graphics.UI.WXCore++data MoveShort = MoveShort {num :: Int, turnColor :: PColor, move :: String}++moveShort :: Move -> MoveShort+moveShort m = MoveShort (moveNumber m) (turn m) (fromJust $ movePretty m)++wxGameMoves :: SplitterWindow () -> TVar [Move] -> IO (ScrolledWindow (), IO ())+wxGameMoves f t = do+  sw     <- scrolledWindow f [ scrollRate := sz 5 5]+  p <- panel sw []+  txtCtrls <- replicateM 250 (staticTextSmall p "")+  let update = do+            moves <- readTVarIO t+            let mx = reverse $ moveShort <$> filter (isJust . movePretty) moves+            let labels = layoutMoves mx+            zipWithM_ (\tCtrl mv -> set tCtrl [text := mv, visible := True]) txtCtrls labels+            sizerX <- sizerFromLayout sw  (if null mx then empty+                                           else container p $ margin 30 $  grid 5 0 (layoutSt $ take (length labels) txtCtrls))+            windowSetSizer sw sizerX+            windowFitInside sw++  update+  return (sw, update)++layoutSt (t1:t2:t3:tx) = [ vspace 18+                         , widget t1+                         , widget t2+                         , widget t3] : layoutSt tx+layoutSt _ = []+++layoutMoves :: [MoveShort] -> [String]+layoutMoves [] = []+layoutMoves [s1]+  | turnColor s1 == White = [show (num s1 - 1) ++ ".", "...", move s1]+  | otherwise = [show (num s1) ++ ".", move s1, ""]+layoutMoves (s1:s2:sx)+  | turnColor s1 == White = [show (num s1 - 1) ++ ".", "...", move s1] ++ layoutMoves (s2:sx)+  | otherwise = [show (num s1) ++ ".", move s1, move s2] ++ layoutMoves sx++++staticTextSmall :: Panel () -> String -> IO (StaticText ())+staticTextSmall p s = staticText p [ text := s+                                       , fontFace := "Avenir Next Medium"+                                       , fontSize := 14+                                       , visible := False+                                       , fontWeight := WeightNormal]++{-++--  selected <- readTVarIO vSel+--  vSel <- newTVarIO 0+--  set (txtCtrl $ mx' !! selected) [bgcolor := red]+--  set p [on rightKey := doRightKey vSel mx' ]+--  set p [on leftKey := doLeftKey vSel mx' ]++doRightKey vSel mx = do+  selected <- readTVarIO vSel+  set (txtCtrl $ mx !! selected) [bgcolor := colorSystem ColorBackground]+  selected <- atomically $ modifyTVar vSel (\x -> min (length mx - 1) (x + 1)) >> readTVar vSel+  set (txtCtrl $ mx !! selected) [bgcolor := red]++doLeftKey vSel mx = do+  selected <- readTVarIO vSel+  set (txtCtrl $ mx !! selected) [bgcolor := colorSystem ColorBackground]+  selected <- atomically $ modifyTVar vSel (\x -> max 0 (x - 1)) >> readTVar vSel+  set (txtCtrl $ mx !! selected) [bgcolor := red]+-}++
+ src/Macbeth/Wx/GameType.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts #-}++module Macbeth.Wx.GameType (+  Category (..),+  Board (..),+  gameTypes,+  gameTypeSelectionToString,+  onSelectGameTypeCategory+) where++import Macbeth.Wx.Utils++import Data.Char+import Data.Map+import Graphics.UI.WX++data Category = Chess | Suicide | Losers | Atomic | Wild | Crazyhouse | Bughouse deriving (Eq, Ord, Show, Read)++data Board = Board {_id :: String, display :: String} deriving (Show, Read)++gameTypes :: Map Category [Board]+gameTypes = fromList [ (Chess, []), (Suicide, []), (Losers, []), (Atomic, []),+                       (Wild, [    Board "w1" "Reversed King and Queen"+                                 , Board "w2" "Shuffle position"+                                 , Board "w3" "Shuffle position, mirrored"+                                 , Board "w4" "Random pieces, balanced bishops"+                                 , Board "w5" "Pawns on 7th rank"+                                 , Board "w8" "Pawns on 4th rank"+                                 , Board "w8a" "Panwns on 5th rank"+                                 , Board "wild fr" "Fisher Random"])+                     , (Crazyhouse, [])+                     , (Bughouse, [])]+++gameTypeSelectionToString :: Category -> Maybe Board -> String+gameTypeSelectionToString _ (Just board) = _id board+gameTypeSelectionToString cat _ = fmap toLower (show cat)+++onSelectGameTypeCategory :: Choice () -> Choice () -> IO ()+onSelectGameTypeCategory c_boards c_category = do+  category <- fmap read (getDisplaySelection c_category)+  set c_boards [ items := fmap display $ gameTypes ! category]+
+ src/Macbeth/Wx/GamesList.hs view
@@ -0,0 +1,75 @@+module Macbeth.Wx.GamesList (+  wxGamesList+) where++import Macbeth.Fics.Api.Game+import Macbeth.Fics.FicsMessage+import Macbeth.Wx.Utils++import Graphics.UI.WX hiding (refresh)+import Graphics.UI.WXCore+import System.IO++data GamesOpts = GamesOpts { refresh :: MenuItem ()+                           , showRated :: MenuItem ()+                           , showUnrated :: MenuItem ()+                           }++wxGamesList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())+wxGamesList glp h = do+  gl  <- listCtrl glp [ columns :=+      [ ("#", AlignLeft, -1)+      , ("Player 1", AlignLeft, -1)+      , ("Rating", AlignLeft, -1)+      , ("Player 2", AlignLeft, -1)+      , ("Rating", AlignLeft, -1)+      , ("Game type", AlignLeft, -1)+      ]]+  listCtrlSetColumnWidths gl 100++  glCtxMenu <- menuPane []+  gamesOpts <- getGamesOpts glCtxMenu+  set (refresh gamesOpts) [on command := hPutStrLn h "4 games"]+  return (gl, handler gamesOpts gl glCtxMenu h)+++handler :: GamesOpts -> ListCtrl () -> Menu () -> Handle -> FicsMessage -> IO ()+handler gamesOpts gl glCtxMenu h cmd = case cmd of+  Games games -> do+    filterGamesList gl gamesOpts games+    set (showRated gamesOpts) [on command := filterGamesList gl gamesOpts games]+    set (showUnrated gamesOpts) [on command := filterGamesList gl gamesOpts games]+    set gl [on listEvent := onGamesListEvent gl h]++    listItemRightClickEvent gl (\evt -> do+      pt <- listEventGetPoint evt+      menuPopup glCtxMenu pt gl)+  _ -> return ()+++onGamesListEvent :: ListCtrl() -> Handle -> EventList -> IO ()+onGamesListEvent gl h evt = case evt of+  ListItemActivated idx -> listCtrlGetItemText gl idx >>= hPutStrLn h . ("4 observe " ++)+  _ -> return ()+++filterGamesList :: ListCtrl () -> GamesOpts -> [Game] -> IO ()+filterGamesList gl opts games = do+  showRated' <- get (showRated opts) checked+  showUnrated' <- get (showUnrated opts) checked+  set gl [items := [ toList g | g <- games+                   , (isRated (settings g) == showRated') ||+                     (isRated (settings g) == not showUnrated')+                   , not $ isPrivate $ settings g]]+++getGamesOpts :: Menu () -> IO GamesOpts+getGamesOpts ctxMenu = GamesOpts+  <$> menuItem ctxMenu [ text := "Refresh" ]+  <*> menuItem ctxMenu [ text := "Show rated games", checkable := True, checked := True]+  <*> menuItem ctxMenu [ text := "Show unrated games", checkable := True, checked := True]+++toList :: Game -> [String]+toList g = [show $ Macbeth.Fics.Api.Game.id g, nameW g, show $ ratingW g, nameB g, show $ ratingB g, show $ gameType $ settings g]+
+ src/Macbeth/Wx/Login.hs view
@@ -0,0 +1,66 @@+module Macbeth.Wx.Login (+  wxLogin+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Wx.Utils++import Control.Concurrent.Chan+import Graphics.UI.WX+import Graphics.UI.WXCore+import System.IO++data WxLogin = WxLogin {+    name :: TextCtrl ()+  , password :: TextCtrl ()+  , guestLogin :: CheckBox ()+}+++wxLogin :: Handle -> Chan FicsMessage -> IO ()+wxLogin h chan = do+  f <- frameFixed [ text := "Macbeth" ]+  p <- panel f []+  wxInputs <- loginInputs p+  set (guestLogin wxInputs) [on command := toggleLoginFields wxInputs]++  b_ok  <- button p [text := "Login", on command := okBtnHandler wxInputs f h chan]+  b_can <- button p [text := "Quit", on command := close f]++  set f [ defaultButton := b_ok+        , layout := container p $ margin 10 $ column 25 [+              boxed "Login @ freechess.org" (grid 15 15 [+                [ label "Username:", hfill $ widget $ name wxInputs]+               ,[ label "Password:", hfill $ widget $ password wxInputs]+               ,[ label "Login as Guest:", hfill $ widget $ guestLogin wxInputs]])+            , floatBottomRight $ row 5 [widget b_ok, widget b_can]]+        ]+  dupChan chan >>= registerWxCloseEventListener f+++okBtnHandler :: WxLogin -> Frame() -> Handle -> Chan FicsMessage -> IO ()+okBtnHandler wxInputs f h chan = do+  isGuestLogin <- get (guestLogin wxInputs) checked+  username <- get (name wxInputs) text+  hPutStrLn h (if isGuestLogin then "guest" else username) >> loop >> close f+  where+    loop = readChan chan >>= handlePw++    handlePw :: FicsMessage -> IO ()+    handlePw Password = get (password wxInputs) text >>= hPutStrLn h+    handlePw (GuestLogin _) = hPutStrLn h ""+    handlePw Login = return ()+    handlePw _ = loop+++loginInputs :: Panel () -> IO WxLogin+loginInputs p = WxLogin+  <$> textEntry p [alignment := AlignRight]+  <*> textCtrlEx p wxTE_PASSWORD [alignment := AlignRight]+  <*> checkBox p []++toggleLoginFields :: WxLogin -> IO ()+toggleLoginFields wxLogin = do+  isChecked <- get (guestLogin wxLogin) checked+  set (name wxLogin) [enabled := not isChecked]+  set (password wxLogin) [enabled := not isChecked]
+ src/Macbeth/Wx/Match.hs view
@@ -0,0 +1,76 @@+module Macbeth.Wx.Match (+  wxMatch+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Wx.GameType+import Macbeth.Wx.Utils++import Control.Concurrent.Chan+import Data.Map+import Data.Char+import Graphics.UI.WX hiding (color)+import Safe+import System.IO++data WxMatch = WxMatch {+  category :: Choice (),+  board :: Choice (),+  name :: TextCtrl (),+  time :: TextCtrl (),+  inc :: TextCtrl (),+  rated :: CheckBox (),+  color :: Choice ()+}++wxMatch :: Handle -> Bool -> Chan FicsMessage -> IO ()+wxMatch h isGuest chan = do+  f <- frameFixed [ text := "Create a match" ]+  p <- panel f []+  match <- matchInputs p isGuest+  set (category match) [on select ::= onSelectGameTypeCategory (board match)]++  b_ok  <- button p [text := "Match", on command := toString match >>= hPutStrLn h >> close f ]+  b_can <- button p [text := "Cancel", on command := close f]++  set f [ defaultButton := b_ok+        , layout := container p $ margin 10 $ column 10 [+               boxed "Game Type" (grid 15 15 [+                   [label "Category: ", hfill $ widget $ category match]+                 , [label "Board:" , hfill $ widget $ board match ]])+             , boxed "" (grid 15 15 [+                [ label "Player name:", hfill $ widget $ name match]+               ,[ label "Rated:", hfill $ widget $ rated match]+               ,[ label "Time:", hfill $ widget $ time match]+               ,[ label "Inc:", hfill $ widget $ inc match]+               ,[ label "Color:", hfill $ widget $ color match]+              ])+            , floatBottomRight $ row 5 [widget b_can, widget b_ok]]+        ]+  registerWxCloseEventListener f chan+++matchInputs :: Panel () -> Bool -> IO WxMatch+matchInputs p isGuest = WxMatch+  <$> choice p [ items := fmap show (keys gameTypes)]+  <*> choice p []+  <*> textEntry p [ ]+  <*> textEntry p [ text := "5" ]+  <*> textEntry p [ text := "0" ]+  <*> checkBox p [ enabled := not isGuest ]+  <*> choice p [ tooltip := "color", sorted := False, items := ["Automatic", "White", "Black"]]+++-- 4 match GuestXYZZ rated 5 0 white+toString:: WxMatch -> IO String+toString m = (("4 match " ++) . unwords) `fmap` sequence [+       get (name m) text+     , convertIsRated `fmap` get (rated m) enabled+     , get (time m) text+     , get (inc m) text+     , get (color m) selection >>= fmap convertColor . get (color m) . item+     , gameTypeSelectionToString <$> read `fmap` getDisplaySelection (category m)+                                 <*> readMay `fmap` getDisplaySelection (board m)]+    where+      convertIsRated r = if r then "rated" else "unrated"+      convertColor x = if x == "Automatic" then "" else fmap toLower x
+ src/Macbeth/Wx/PartnerOffer.hs view
@@ -0,0 +1,35 @@+module Macbeth.Wx.PartnerOffer (+  wxPartnerOffer+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Player+import Macbeth.Wx.Utils++import Control.Concurrent+import Graphics.UI.WX+import System.IO+++wxPartnerOffer :: Handle -> UserHandle -> Chan FicsMessage  -> IO ()+wxPartnerOffer h userHandle chan = do+  f <- frame []+  p <- panel f []++  b_accept  <- button p [text := "Accept", on command := hPutStrLn h ("5 partner" ++ name userHandle) >> close f]+  b_decline <- button p [text := "Decline", on command := hPutStrLn h "5 decline" >> close f]+  st_params <- staticText p [ text := name userHandle ++ " offers to be your bughouse partner."+                            , fontFace := "Avenir Next Medium"+                            , fontSize := 16+                            , fontWeight := WeightBold]++  set f [ defaultButton := b_accept+        , layout := container p $ margin 10 $+            column 5 [boxed "Bughouse" (+              grid 5 5 [+                [ hfill $ widget st_params]]+            )+            , floatBottomRight $ row 5 [widget b_accept, widget b_decline]]+        ]++  dupChan chan >>= registerWxCloseEventListener f
+ src/Macbeth/Wx/Pending.hs view
@@ -0,0 +1,82 @@+module Macbeth.Wx.Pending (+  wxPending+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.PendingOffer+import Macbeth.Wx.Utils++import Control.Concurrent.STM+import Graphics.UI.WX+import Graphics.UI.WXCore+import System.IO+++data PendingActions =+    PendingTo { accept :: MenuItem (), decline :: MenuItem ()}+  | PendingFrom { withdraw :: MenuItem () }+++wxPending :: Handle -> Panel () -> IO (Panel (), FicsMessage -> IO ())+wxPending h p' = do+  p <- panel p' []+  stFrom <- staticText p [ text := "Offers from other players:", fontSize := 12]+  lcFrom  <- listCtrl p [ columns := [ ("#", AlignLeft, -1), ("offer", AlignLeft, -1)]]+  vPending <- newTVarIO ([] :: [PendingOffer])++  stTo <- staticText p [ text := "Offers to other players:", fontSize := 12]+  lcTo  <- listCtrl p [columns := [ ("#", AlignLeft, -1), ("offer", AlignLeft, -1)]]++  set p [ layout := column 5 [ hfill $ widget stFrom+                             , fill $ widget lcFrom+                             , hfill $ widget $ vspace 5+                             , hfill $ widget $ hrule 1+                             , hfill $ widget $ vspace 5+                             , hfill $ widget stTo+                             , fill $ widget lcTo]]++  listItemRightClickEvent lcFrom (ctxMenuHandler h lcFrom From)+  listItemRightClickEvent lcTo (ctxMenuHandler h lcTo To)++  let handler cmd = case cmd of++                Pending offer -> do+                  atomically $ modifyTVar vPending (++ [offer])+                  itemAppend (if isFrom offer then lcFrom else lcTo) (toList offer)++                PendingRemoved idx -> do+                  items <- atomically $ do+                    modifyTVar vPending $ filter ((/= idx) . offerId)+                    readTVar vPending+                  itemsDelete lcFrom+                  itemsDelete lcTo+                  mapM_ (itemAppend lcTo) (fmap toList (filter isTo items))+                  mapM_ (itemAppend lcFrom) (fmap toList (filter isFrom items))+                _ -> return ()++  return (p, handler)+++toList :: PendingOffer -> [String]+toList (PendingOffer _ id _ _ params) = [show id, params]+++ctxMenuHandler :: Handle -> ListCtrl () -> Origin -> Graphics.UI.WXCore.ListEvent () -> IO ()+ctxMenuHandler h listCtrl origin evt = do+  ctxMenu <- menuPane []+  idx <- listEventGetIndex evt+  offerId <- (head . (!! idx)) <$> get listCtrl items+  _ <- (if origin == To then menuPendingTo else menuPendingFrom) ctxMenu h offerId+  when (idx >= 0) $ listEventGetPoint evt >>= flip (menuPopup ctxMenu) listCtrl+++menuPendingFrom :: Menu () -> Handle -> String -> IO PendingActions+menuPendingFrom ctxMenu h offerId = PendingTo+  <$> menuItem ctxMenu [ text := "Accept", on command := hPutStrLn h ("4 accept " ++ offerId)]+  <*> menuItem ctxMenu [ text := "Decline", on command := hPutStrLn h ("4 decline " ++ offerId)]+++menuPendingTo :: Menu () -> Handle -> String -> IO PendingActions+menuPendingTo ctxMenu h offerId = PendingFrom+  <$> menuItem ctxMenu [ text := "Withdraw", on command := hPutStrLn h ("4 withdraw " ++ offerId)]+
+ src/Macbeth/Wx/PieceSet.hs view
@@ -0,0 +1,29 @@+module Macbeth.Wx.PieceSet (+  PieceSet(..),+  pieceSets,+  pieceSetFindSize+) where++import Data.Maybe+import Safe+++{-+http://ixian.com/chess/jin-piece-sets/+This work by Eric De Mund is licensed under a Creative Commons Attribution-Share Alike 3.0 Unported License+-}++data PieceSet = PieceSet { path :: FilePath, display :: String }++pieceSets = [+    PieceSet "alpha.ead-01" "Alpha (ead-01)"+  , PieceSet "alpha.ead-02" "Alpha (ead-02)"+  , PieceSet "merida.ead-01" "Merida (ead-01)"+  , PieceSet "merida.ead-02" "Merida (ead-02)"+  , PieceSet "uscf.ead-01" "USCF (ead-01)"+  , PieceSet "uscf.ead-02" "USCF (ead-02)"]++pieceSetFindSize :: Int -> Int+pieceSetFindSize panelWidth =+  fromMaybe 300 $ headMay $ dropWhile (< round (fromIntegral panelWidth / 8)) sizes+  where sizes = [20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,52,56,60,64,72,80,88,96,112,128,144,300]
+ src/Macbeth/Wx/PlayersList.hs view
@@ -0,0 +1,103 @@+module Macbeth.Wx.PlayersList (+  wxPlayersList+) where++import Macbeth.Fics.Api.Player+import Macbeth.Fics.FicsMessage+import Macbeth.Wx.Utils++import Paths++import Data.List+import Graphics.UI.WX hiding (when)+import Graphics.UI.WXCore hiding (when)+import System.IO+++data CtxMenu = CtxMenu {+    match :: MenuItem ()+  , finger :: MenuItem ()+  , history :: MenuItem ()+  , observe :: MenuItem ()+  , partner :: MenuItem ()+}++wxPlayersList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())+wxPlayersList slp h = do+    sl <- listCtrl slp [columns := [+        ("Handle", AlignLeft, -1)+      , ("State", AlignRight, -1)+      , ("Rating", AlignRight, -1)+      , ("Title", AlignRight, -1)]]++    listCtrlSetColumnWidths sl 120+    images >>= flip (listCtrlAssignImageList sl) wxIMAGE_LIST_SMALL++    ctxMenu <- menuPane []+    ctxMenuPopup <- createCtxMenu ctxMenu+    let updateM user (f, cmd) = set (f ctxMenuPopup) [on command := hPutStrLn h $ "6 " ++ cmd ++ " " ++ user]++    listItemRightClickEvent sl (\evt -> do+      player <- listEventGetIndex evt >>= get sl . item+      sequence_ $ fmap (updateM (head player)) [(finger, "finger"), (partner, "partner"),+        (match, "match"), (history, "history"), (observe, "observe")]+      listEventGetPoint evt >>= flip (menuPopup ctxMenu) sl)++    return (sl, handler sl)+++handler :: ListCtrl () -> FicsMessage -> IO ()+handler sl cmd = case cmd of+  Players players -> do+    listCtrlDeleteAllItems sl+    sequence_ $ fmap (addPlayer sl) players+  _ -> return ()+++images :: IO (ImageList ())+images = do+  let imageFiles = map (\name -> "icons/" ++ name ++ ".gif") ["fa-user", "fa-desktop"]+  imagePaths <- mapM getDataFileName imageFiles+  imageListFromFiles (sz 16 16) imagePaths+++addPlayer :: ListCtrl () -> Player -> IO ()+addPlayer l player = do+  count <- listCtrlGetItemCount l++  item <- listItemCreate+  listItemSetId item count+  --when (Computer `elem` titles seek) $ listItemSetBackgroundColour item (colorRGB 125 149 184)+  listItemSetImage item (fmap imageIdx handleType $ handle player)++  listCtrlInsertItem l item+  mapM_ (\(column,txt) -> listCtrlSetItem l count column txt (-1)) (zip [0..] (toList player))++  where+    imageIdx :: [HandleType] -> Int+    imageIdx types = if Computer `elem` types then 1 else 0+++createCtxMenu :: Menu () -> IO CtxMenu+createCtxMenu ctxMenu = CtxMenu+  <$> menuItem ctxMenu [ text := "Match"]+  <*> menuItem ctxMenu [ text := "Finger"]+  <*> menuItem ctxMenu [ text := "History"]+  <*> menuItem ctxMenu [ text := "Observe"]+  <*> menuItem ctxMenu [ text := "Partner"]++toList :: Player -> [String]+toList (Player rating status (UserHandle username ht)) =+  [username, toStringStatus status, show rating, showHandleType ht]+  where+    toStringStatus InvolvedInAGame = "Playing"+    toStringStatus RunningASimulMatch = "Playing Simul"+    toStringStatus NotOpenForMatch = "Not Open"+    toStringStatus ExaminingAGame = "Examining"+    toStringStatus InactiveOrBusy = "Inactive"+    toStringStatus NotBusy = "Not Busy"+    toStringStatus InvolvedInATournament = "Tournament"++    showHandleType = intercalate ", " . fmap show .+      filter (not . flip elem [Unregistered, Computer, NOT_DOCUMENTED, ServiceRepresentative])+
+ src/Macbeth/Wx/Seek.hs view
@@ -0,0 +1,118 @@+module Macbeth.Wx.Seek (+    wxSeek+  , toString+  , SeekInfo (..)+) where++import Macbeth.Fics.Api.Api+import Macbeth.Fics.FicsMessage+import Macbeth.Wx.GameType+import Macbeth.Wx.Utils++import Control.Concurrent.Chan+import Data.Map (keys)+import Graphics.UI.WX hiding (color)+import Safe+import System.IO++-- seek [time inc] [rated|unrated] [white|black] [crazyhouse] [suicide] [wild #] [auto|manual] [formula] [rating-range]+data WxSeek = WxSeek {+    category :: Choice ()+  , board :: Choice ()+  , time :: TextCtrl ()+  , inc :: TextCtrl ()+  , rated :: CheckBox ()+  , color :: Choice ()+  , manual :: CheckBox ()+--, formula :: CheckBox ()+  , ratingFrom :: TextCtrl ()+  , ratingTo :: TextCtrl ()+}++data SeekInfo = SeekInfo {+    _category :: Category+  , _board :: Maybe Board+  , _time :: Int+  , _inc :: Int+  , _rated :: Bool+  , _color :: Maybe PColor+  , _manual :: Bool+--  , _formula :: Bool+  , _ratingFrom :: Int+  , _ratingTo :: Int+}+++wxSeek :: Handle -> Bool -> Chan FicsMessage -> IO ()+wxSeek h isGuest chan = do+  f <- frameFixed [ text := "Seek a match" ]+  p <- panel f []+  match <- matchInputs p isGuest+  set (category match) [on select ::= onSelectGameTypeCategory (board match)]++  b_ok  <- button p [text := "Create", on command := readSeek match >>= hPutStrLn h . ("4 seek " ++) . toString >> close f ]+  b_can <- button p [text := "Cancel", on command := close f]++  set f [ defaultButton := b_ok+        , layout := container p $ margin 10 $ column 15 [+            boxed "Game Type" (grid 15 15 [+              [label "Category: ", hfill $ widget $ category match, label "Board:", hfill $ widget $ board match ]+            ]),+            boxed "" (grid 15 15 [+                  [ label "Time [min.]:", hfill $ widget $ time match, label "Inc [sec.]:", hfill $ widget $ inc match]+                , [ label "Rated:", hfill $ widget $ rated match, label "Color:", hfill $ widget $ color match]+                , [ label "Manual accept:", hfill $ widget $ manual match, empty, empty]+                , [ label "Rating from", hfill $ widget $ ratingFrom match, label "to", hfill $ widget $ ratingTo match]+              ])+            , floatBottomRight $ row 5 [widget b_can, widget b_ok]]+        ]+  registerWxCloseEventListener f chan+++-- seek [time inc] [rated|unrated] [white|black] [crazyhouse] [suicide]+--      [wild #] [auto|manual] [formula] [rating-range]+toString :: SeekInfo -> String+toString m = unwords $ filter (/= "") [+    show $ _time m+  , show $ _inc m+  , convertIsRated $ _rated m+  , maybe "" convertColor (_color m)+  , gameTypeSelectionToString (_category m) (_board m)+  , convertAutoManual (_manual m)+  , convertRatingRange (_ratingFrom m) (_ratingTo m)]+    where+      convertIsRated r = if r then "r" else "u"+      convertColor White = "w"+      convertColor Black = "b"+      convertRatingRange from to = show from ++ "-" ++ show to+      convertAutoManual isManual = if isManual then "m" else "a"+++readSeek :: WxSeek -> IO SeekInfo+readSeek m = SeekInfo+  <$> read `fmap` getDisplaySelection (category m)+  <*> readMay `fmap` getDisplaySelection (board m)+  <*> read `fmap` get (time m) text+  <*> read `fmap` get (inc m) text+  <*> get (rated m) checked+  <*> convertColor `fmap` getDisplaySelection (color m)+  <*> get (manual m) checked+  <*> read `fmap` get (ratingFrom m) text+  <*> read `fmap` get (ratingTo m) text+  where+    convertColor "Automatic" = Nothing+    convertColor c = read c+++matchInputs :: Panel () -> Bool -> IO WxSeek+matchInputs p isGuest = WxSeek+  <$> choice p [items := fmap show (filter (/= Bughouse) $ keys gameTypes)]+  <*> choice p []+  <*> textEntry p [ text := "5"]+  <*> textEntry p [ text := "0"]+  <*> checkBox p [ enabled := not isGuest ]+  <*> choice p [tooltip := "color", sorted := False, items := ["Automatic", "White", "Black"]]+  <*> checkBox p []+  <*> textEntry p [ text := "0"]+  <*> textEntry p [ text := "9999"]+
+ src/Macbeth/Wx/SoughtList.hs view
@@ -0,0 +1,139 @@+module Macbeth.Wx.SoughtList (+  wxSoughtList+) where++import Macbeth.Fics.Api.Seek+import Macbeth.Fics.Api.Game hiding (gameType, isRated)+import Macbeth.Fics.FicsMessage+import Macbeth.Wx.Utils+import Paths++import Control.Concurrent.STM+import Control.Monad+import Graphics.UI.WX hiding (when)+import Graphics.UI.WXCore hiding (when)+import System.IO+import Data.List (elemIndex)++data SoughtOpts = SoughtOpts { computerOffers :: MenuItem ()+                             , unregisteredPlayers :: MenuItem ()+                             , unratedOffers :: MenuItem ()+                             , ratedOffers :: MenuItem () }++wxSoughtList :: Panel () -> Handle -> IO (ListCtrl (), FicsMessage -> IO ())+wxSoughtList slp h = do+    sl  <- listCtrl slp [columns := [ ("#", AlignLeft, -1)+                                    , ("Handle", AlignLeft, -1)+                                    , ("Rating", AlignLeft, -1)+                                    , ("Time (start inc.)", AlignRight, -1)+                                    , ("Type", AlignRight, -1)]+                                    ]++    set sl [on listEvent := onSeekListEvent sl h]+    listCtrlSetColumnWidths sl 100++    ctxMenu <- menuPane []+    soughtOpts <- getSoughtOpts ctxMenu+    vSoughtList <- newTVarIO ([] :: [Seek])++    set (computerOffers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]+    set (unregisteredPlayers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]+    set (unratedOffers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]+    set (ratedOffers soughtOpts) [on command := filterSoughtList sl soughtOpts vSoughtList]++    listItemRightClickEvent sl (\evt -> do+                pt <- listEventGetPoint evt+                menuPopup ctxMenu pt sl)++    imagePaths <- mapM getDataFileName imageFiles+    images     <- imageListFromFiles (sz 16 16) imagePaths++    listCtrlAssignImageList sl images wxIMAGE_LIST_SMALL++    let handler cmd = case cmd of+            NewSeek seek -> do+              atomically $ modifyTVar vSoughtList (\sl -> sl ++ [seek])+              showSeek' <- showSeek soughtOpts+              when (showSeek' seek) $ addSeek sl seek++            ClearSeek -> itemsDelete sl++            RemoveSeeks gameIds -> do+              seeks <- get sl items+              sequence_ $ fmap (deleteSeek sl . findSeekIdx seeks) gameIds++            _ -> return ()++    return (sl, handler)++imageNames = ["fa-user", "fa-desktop"]+++imageFiles = map (\name -> "icons/" ++ name ++ ".gif") imageNames+++addSeek :: ListCtrl () -> Seek -> IO ()+addSeek l seek = do+  count <- listCtrlGetItemCount l++  item <- listItemCreate+  listItemSetId item count+  --when (Computer `elem` titles seek) $ listItemSetBackgroundColour item (colorRGB 125 149 184)+  listItemSetImage item $ if Computer `elem` titles seek then 1 else 0++  listCtrlInsertItem l item+  mapM_ (\(column,txt) -> listCtrlSetItem l count column txt (-1)) (zip [0..] (toList seek))+++showSeek :: SoughtOpts -> IO (Seek -> Bool)+showSeek opts = do+  computerOffers' <- get (computerOffers opts) checked+  unregisteredPlayers' <- get (unregisteredPlayers opts) checked+  unratedOffers' <- get (unratedOffers opts) checked+  ratedOffers' <- get (ratedOffers opts) checked+  return $ \s -> (gameType s `elem` [Untimed, Standard, Blitz, Lightning]) &&+                 ((Computer `elem` titles s) .>. computerOffers') &&+                 ((Unregistered `elem` titles s) .>. unregisteredPlayers') &&+                 (isRated s .>. ratedOffers') &&+                 (not (isRated s) .>. unratedOffers')+++(.>.) :: Bool -> Bool -> Bool+(.>.) p q = (not p) || q+++filterSoughtList :: ListCtrl () -> SoughtOpts -> TVar [Seek] -> IO ()+filterSoughtList sl opts vSoughtList = do+  showSeek' <- showSeek opts+  soughts <- readTVarIO vSoughtList+  listCtrlDeleteAllItems sl+  mapM_ (\s -> when (showSeek' s) $ addSeek sl s) soughts+++onSeekListEvent :: ListCtrl() -> Handle -> EventList -> IO ()+onSeekListEvent sl h evt = case evt of+  ListItemActivated idx -> listCtrlGetItemText sl idx >>= hPutStrLn h . ("4 play " ++)+  _ -> return ()+++findSeekIdx :: [[String]] -> Int -> Maybe Int+findSeekIdx seeks gameId = elemIndex gameId $ fmap (read . (!! 0)) seeks+++deleteSeek :: ListCtrl () -> Maybe Int -> IO ()+deleteSeek sl (Just id) = itemDelete sl id+deleteSeek _ _ = return ()+++getSoughtOpts :: Menu () -> IO SoughtOpts+getSoughtOpts ctxMenu = SoughtOpts+  <$> menuItem ctxMenu [ text := "Show computer offers", checkable := True, checked := True]+  <*> menuItem ctxMenu [ text := "Show unregistered players", checkable := True, checked := True]+  <*> menuItem ctxMenu [ text := "Show unrated offers", checkable := True, checked := True]+  <*> menuItem ctxMenu [ text := "Show rated offers", checkable := True, checked := True]++toList :: Seek -> [String]+toList (Seek id name _ rating time inc isRated gameType _ _) =+  [show id, name, show rating, show time ++ " " ++ show inc, show gameType ++ " " ++ showIsRated isRated]+  where showIsRated True = "rated"+        showIsRated False = "unrated"
+ src/Macbeth/Wx/StatusPanel.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE LambdaCase #-}++module Macbeth.Wx.StatusPanel (+  createStatusPanel+) where++import Macbeth.Fics.FicsMessage hiding (gameId, Observing)+import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Move+import Macbeth.Utils.Utils+import Macbeth.Utils.BoardUtils+import Macbeth.Wx.BoardState+import Macbeth.Wx.PieceSet+import Macbeth.Wx.Utils++import Control.Arrow+import Control.Concurrent.STM+import Control.Monad+import Data.List+import Graphics.UI.WX hiding (when)+++createStatusPanel :: Panel () -> PColor -> TVar BoardState -> IO (Panel (), FicsMessage -> IO ())+createStatusPanel p color vBoardState = do+  move <- lastMove `fmap` readTVarIO vBoardState++  p_status <- panel p []+  t <- newTVarIO $ remainingTime color move+  st <- staticTextFormatted p_status (formatTime $ remainingTime color move)+  tx <- timer p_status [ interval := 1000+                , on command := updateTime t st+                , enabled := isActive move color]++  p_color <- panel p_status [bgcolor := toWxColor color]+  st_playerName <- staticTextFormatted p_status (namePlayer color move)+  p_pieceHoldings <- panel p_status [on paint := paintPieceHolding color vBoardState]++  set p_status [ layout := row 10 [ valignCenter $ minsize (Size 18 18) $ widget p_color+                                  , widget st+                                  , widget st_playerName+                                  , marginWidth 5 $ marginTop $ fill $ widget p_pieceHoldings] ]++  let handler = \case++        GameMove _ move' -> when (gameId move' == gameId move) $ do+          let time' = remainingTime color move'+          atomically $ swapTVar t time'+          set st [text := formatTime time']+          set tx [enabled := isActive move' color]++        GameResult id _ _ -> when (id == gameId move) $ set tx [enabled := False]++        PieceHolding id phW' phB' -> when (id == gameId move) $ do+          atomically $ modifyTVar vBoardState (\s -> s{ phW = phW', phB = phB' })+          repaint p_status++        _ -> return ()++  return (p_status, handler)+++paintPieceHolding :: PColor -> TVar BoardState -> DC a -> t -> IO ()+paintPieceHolding color state dc _ = do+  px <- getPieceHolding color `fmap` readTVarIO state+  zipWithM_ (drawPiece dc color) [A .. H] (frequency px)+  where+    frequency :: Ord a => [a] -> [(a, Int)]+    frequency = map (head &&& length) . group . sort++drawPiece :: DC a -> PColor -> Column -> (PType, Int) -> IO ()+drawPiece dc color col (ptype, freq) = do+  drawBitmap dc (pieceToBitmap pieceSize (head pieceSets) (Piece ptype color))+                (toPos' fieldSize (Square col Eight) White) True []+  set dc [pen := penColored black 2]+  drawText dc (show freq) (Point (22 + fromEnum col * fieldSize) 15)+    [ fontFace := "Avenir Next Medium"+    , fontSize := 10+    , fontWeight := WeightBold]+  where fieldSize = 35+        pieceSize = 24+++updateTime :: TVar Int -> StaticText () -> IO ()+updateTime vTime st = do+  time <- atomically $ modifyTVar vTime (\t -> t - 1) >> readTVar vTime+  set st [text := formatTime time]+++isActive :: Move -> PColor -> Bool+isActive move' color =+  (moveNumber move' /= 1) &&+  (turn move' == color) &&+  (relation move' `elem` [OponentsMove, MyMove, Observing])
+ src/Macbeth/Wx/ToolBox.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Macbeth.Wx.ToolBox (+  wxToolBox+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Player+import Macbeth.Wx.Configuration+import Macbeth.Wx.Finger+import Macbeth.Wx.GamesList+import Macbeth.Wx.Login+import Macbeth.Wx.Match+import Macbeth.Wx.Seek+import Macbeth.Wx.Utils+import Macbeth.Wx.PlayersList+import Macbeth.Wx.SoughtList+import Macbeth.Wx.Game+import Macbeth.Wx.Challenge+import Macbeth.Wx.PartnerOffer+import Macbeth.Wx.Pending+import Paths++import Control.Concurrent+import Control.Concurrent.Chan ()+import Control.Monad+import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.Ptr+import Foreign.C.Types+import Graphics.UI.WX hiding (when)+import Graphics.UI.WXCore hiding (when)+import System.FilePath+import System.IO+import System.IO.Unsafe++eventId = wxID_HIGHEST + 1++wxToolBox :: Handle -> Chan FicsMessage -> IO ()+wxToolBox h chan = do+    f  <- frame [ text := "Macbeth"]++    tbar   <- toolBarEx f False False []+    tbarItem_seek <- toolItem tbar "Seek" False (unsafePerformIO $ getDataFileName $ "icons" </> "bullhorn.gif")+      [ on command := dupChan chan >>= wxSeek h False, enabled := False, tooltip := "Seek" ]++    tbarItem_match <- toolItem tbar "Match" False  (unsafePerformIO $ getDataFileName $ "icons" </> "dot-circle-o.gif")+      [ on command := dupChan chan >>= wxMatch h False, enabled := False, tooltip := "Match" ]++    tbarItem_finger <- toolItem tbar "Finger" False  (unsafePerformIO $ getDataFileName $ "icons" </> "fa-question.gif")+      [ on command := hPutStrLn h "4 finger", enabled := False, tooltip := "Finger"]++    status <- statusField []+    statusLag <- statusField [ statusWidth := 100 ]+    _ <- timer f [ interval := 2 * 60 * 1000, on command := hPutStrLn h "4 ping"]+    statusLoggedIn <- statusField [ statusWidth := 100]+++    nb <- notebook f []++    -- Sought list+    slp <- panel nb []+    (sl, soughtListHandler) <- wxSoughtList slp h++    -- Games list+    glp <- panel nb []+    (gl, gamesListHandler)  <- wxGamesList glp h++    -- Pending+    pending <- panel nb []+    (pendingWidget, pendingHandler) <- wxPending h pending++    -- Players+    players <- panel nb []+    (playersWidget, playersHandler) <- wxPlayersList players h++    -- Console+    cp <- panel nb []+    ct <- textCtrlEx cp (wxTE_MULTILINE .+. wxTE_RICH .+. wxTE_READONLY) [font := fontFixed]+    ce <- entry cp []+    set ce [on enterKey := emitCommand ce h]+++    -- menu+    m_file   <- menuPane [text := "&File"]+    menuItem m_file [text := "Settings", on command := dupChan chan >>= wxConfiguration ]++    set f [ statusBar := [status, statusLoggedIn, statusLag],+            layout := tabs nb+                        [ tab "Sought" $ container slp $ fill $ widget sl+                        , tab "Games" $ container glp $ fill $ widget gl+                        , tab "Pending" $ container pending $ fill $ widget pendingWidget+                        , tab "Players" $ container players $ fill $ widget playersWidget+                        , tab "Console" $ container cp ( column 5  [ fill $ widget ct+                                                                   , hfill $ widget ce])+                        ]+          , menuBar := [m_file]+          , outerSize := sz 600 600+          ]++    -- preselect first tab+    notebookSetSelection nb 0++    vCmd <- newEmptyMVar+    threadId <- forkIO $ eventLoop eventId chan vCmd f+    windowOnDestroy f $ writeChan chan WxClose >> killThread threadId++    evtHandlerOnMenuCommand f eventId $ takeMVar vCmd >>= \cmd ->+      gamesListHandler cmd >>+      soughtListHandler cmd >>+      pendingHandler cmd >>+      playersHandler cmd >>+      case cmd of++        NoSuchGame -> do+          set status [text := "No such game. Updating games..."]+          hPutStrLn h "4 games"++        UserNotLoggedIn username -> do+          set status [text := username ++ " is not logged in."]+          hPutStrLn h "4 who"++        PartnerNotOpen userHandle -> set status [text := name userHandle ++ " is not open for bughouse."]++        PartnerOffer userHandle -> dupChan chan >>= wxPartnerOffer h userHandle++        PartnerAccepted userHandle -> set status [text := name userHandle ++ " agrees to be your partner."]++        PartnerDeclined userHandle -> set status [text := name userHandle ++ " declines the partnership request."]++        SeekNotAvailable -> set status [text := "That seek is not available."]++        InvalidPassword  -> void $ set status [text := "Invalid password."]++        LoginTimeout -> set status [ text := "Login Timeout." ]++        Login -> dupChan chan >>= wxLogin h++        LoggedIn handle -> do+          set nb [on click := (onMouse nb >=> clickHandler h nb)]+          hPutStrLn h `mapM_` [ "ping", "set seek 0", "set style 12", "iset pendinfo 1", "iset seekinfo 1", "iset nowrap 1", "iset defprompt 1", "iset block 1", "2 iset lock 1"]+          set statusLoggedIn [ text := name handle]+          mapM_ (`set` [ enabled := True ]) [tbarItem_seek, tbarItem_match, tbarItem_finger]++        GuestLogin _ -> do+          set tbarItem_seek  [on command := dupChan chan >>= wxSeek h True ]+          set tbarItem_match  [on command := dupChan chan >>= wxMatch h True ]++        msg@(Finger {}) -> dupChan chan >>= wxInfo msg++        msg@(History {}) -> dupChan chan >>= wxInfo msg++        WxObserve move chan' -> wxGame h move chan'++        MatchRequested c -> dupChan chan >>= wxChallenge h c++        WxMatchAccepted move chan' -> wxGame h move chan'++        MatchDeclined user -> set status [text := user ++ " declines the match offer."]++        MatchUserNotLoggedIn user -> set status [text := user ++ " not logged in."]++        Ping _ avg _ -> set statusLag [ text := "Lag: " ++ show avg ++ "ms"]++        TextMessage text -> appendText ct text++        _ -> return ()+++emitCommand :: TextCtrl () -> Handle -> IO ()+emitCommand textCtrl h = get textCtrl text >>= hPutStrLn h . ("5 " ++) >> set textCtrl [text := ""]+++onMouse :: Notebook() -> Point -> IO Int+onMouse nb p = propagateEvent >> notebookHitTest nb p flag++clickHandler :: Handle -> Notebook () -> Int -> IO ()+clickHandler h nb idx = notebookGetPageText nb idx >>= \case+  "Games" -> hPutStrLn h "5 games"+  "Players" -> hPutStrLn h "5 who"+  _ -> return ()+++{-# NOINLINE flag #-}+flag :: Ptr CInt+flag  =  unsafePerformIO flag'+  where flag' = do+             work <- malloc::IO (Ptr CInt)+             poke work (fromIntegral wxBK_HITTEST_ONPAGE)+             return work
+ src/Macbeth/Wx/Utils.hs view
@@ -0,0 +1,68 @@+module Macbeth.Wx.Utils (+  eventLoop,+  registerWxCloseEventListener,+  registerWxCloseEventListenerWithThreadId,+  listItemRightClickEvent,+  toWxColor,+  getDisplaySelection,+  staticTextFormatted+) where++import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Api++import Control.Concurrent+import Graphics.UI.WX+import Graphics.UI.WXCore hiding (Column, Row)+++eventLoop :: Int -> Chan FicsMessage -> MVar FicsMessage -> Frame () -> IO ()+eventLoop id chan vCmd f = readChan chan >>= putMVar vCmd >>+  commandEventCreate wxEVT_COMMAND_MENU_SELECTED id >>= evtHandlerAddPendingEvent f >>+  eventLoop id chan vCmd f++registerWxCloseEventListener :: Frame () -> Chan FicsMessage -> IO ()+registerWxCloseEventListener f chan = do+  vCmd <- newEmptyMVar+  threadId <- forkIO $ eventLoop (wxID_HIGHEST + 13) chan vCmd f+  windowOnDestroy f $ killThread threadId++  evtHandlerOnMenuCommand f (wxID_HIGHEST + 13) $ takeMVar vCmd >>= \cmd -> case cmd of+    WxClose -> close f+    _ -> return ()++registerWxCloseEventListenerWithThreadId :: Frame () -> Chan FicsMessage -> IO ThreadId+registerWxCloseEventListenerWithThreadId f chan = do+  vCmd <- newEmptyMVar+  threadId <- forkIO $ eventLoop (wxID_HIGHEST + 13) chan vCmd f++  evtHandlerOnMenuCommand f (wxID_HIGHEST + 13) $ takeMVar vCmd >>= \cmd -> case cmd of+    WxClose -> close f+    _ -> return ()++  return threadId+++listItemRightClickEvent :: ListCtrl a -> (Graphics.UI.WXCore.ListEvent () -> IO ()) -> IO ()+listItemRightClickEvent listCtrl eventHandler+  = windowOnEvent listCtrl [wxEVT_COMMAND_LIST_ITEM_RIGHT_CLICK] eventHandler listHandler+    where+      listHandler :: Graphics.UI.WXCore.Event () -> IO ()+      listHandler evt = eventHandler $ objectCast evt+++getDisplaySelection :: Choice () -> IO String+getDisplaySelection c = get c selection >>= get c . item+++toWxColor :: PColor -> Color+toWxColor White = Graphics.UI.WXCore.white+toWxColor Black = Graphics.UI.WXCore.black+++staticTextFormatted :: Panel () -> String -> IO (StaticText ())+staticTextFormatted p s = staticText p [ text := s+                                       , fontFace := "Avenir Next Medium"+                                       , fontSize := 20+                                       , fontWeight := WeightBold]+
+ src/Paths.hs view
@@ -0,0 +1,13 @@+module Paths (+  getDataFileName+) where++import Data.List+import qualified Paths_Macbeth as PM+import System.Environment.FindBin+import System.FilePath++getDataFileName :: FilePath -> IO FilePath+getDataFileName f+  | "app" `isInfixOf` __Bin__ = ((</> "Resources" </> f) . joinPath . init . splitPath) <$> getProgPath+  | otherwise = PM.getDataFileName f
+ src/Paths_Macbeth.hs view
@@ -0,0 +1,8 @@+module Paths_Macbeth (+  getDataFileName+) where++import System.FilePath++getDataFileName :: FilePath -> IO FilePath+getDataFileName f = return $ "resources" </> f
+ test/FicsMessageParserSpec.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings #-}++module FicsMessageParserSpec (spec) where++import Test.Hspec++import Macbeth.Fics.Api.Api+import Macbeth.Fics.Api.Challenge+import qualified Macbeth.Fics.Api.Rating as R+import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Game+import Macbeth.Fics.Api.Seek+import Macbeth.Fics.Api.Move+import Macbeth.Fics.Api.PendingOffer+import qualified Macbeth.Fics.Api.Player as P+import Macbeth.Fics.Parsers.FicsMessageParser+import Macbeth.Fics.Parsers.MoveParser hiding (move)+import Macbeth.Fics.Parsers.PositionParser++import Data.Attoparsec.ByteString.Char8 hiding (Fail, Result, D)+import qualified Data.ByteString.Char8 as BS++data Result = Pass | Fail String deriving (Eq)++spec :: Spec+spec =+  describe "Parser test" $ do++    it "user not logged in after observe" $ parseFicsMessage "\NAK6\SYN80\SYNDharmadhikari is not logged in.\n\ETB\n"+      `shouldBe` (Right $ UserNotLoggedIn "Dharmadhikari")++    it "command message parser" $ commandMessageParserTest `shouldBe` True++    it "seek msg parser" $ seekMsgParserTest `shouldBe` True++    it "move parser" $ moveParserTest `shouldBe` True++    it "position parser" $ positionTest `shouldBe` True++    it "ping" $ parseFicsMessage ":min/avg/max/mdev = 131.497/132.073/132.718/0.460 ms\n"+      `shouldBe` Right (Ping 131 132 133)++    it "pending from" $ parseFicsMessage "<pf> 28 w=Schoon t=match p=Schoon ( 999) GuestNXQS (----) unrated blitz 5 0\n"+      `shouldBe ` Right (Pending $ PendingOffer From 28 (P.UserHandle "Schoon" []) "match" "Schoon ( 999) GuestNXQS (----) unrated blitz 5 0")++    it "pendingTo" $ parseFicsMessage "\NAK4\SYN73\SYNIssuing: GuestFTYL (----) GuestCVXP (----) unrated blitz 5 0.\n\n<pt> 3 w=GuestCVXP t=match p=GuestFTYL (----) GuestCVXP (----) unrated blitz 5 0\n\ETB\n"+      `shouldBe` Right (Pending $ PendingOffer To 3 (P.UserHandle "GuestCVXP" []) "match" "GuestFTYL (----) GuestCVXP (----) unrated blitz 5 0")++    it "pending removed" $ parseFicsMessage "<pr> 28\n"+      `shouldBe` Right (PendingRemoved 28)++    it "pending removed, after withdraw" $ parseFicsMessage "\NAK4\SYN147\SYNYou withdraw the match offer to GuestFZHQ.\n\n<pr> 1\n\ETB\n"+      `shouldBe` Right (PendingRemoved 1)+++commandMessageParserTest :: Bool+commandMessageParserTest = all (== Pass) $ fmap compareCmdMsg commandMessageParserTestData++commandMessageParserTestData :: [(FicsMessage, String)]+commandMessageParserTestData = [+        (DrawRequest, "GuestDWXY offers you a draw.")+      , (NoSuchGame, "\NAK5\SYN80\SYNThere is no such game.\n\ETB")+      , (MatchRequested $ Challenge "GuestYWYK" R.Unrated "GuestMGSD" R.Unrated "unrated blitz 2 12", "Challenge: GuestYWYK (----) GuestMGSD (----) unrated blitz 2 12.")+      , (GuestLogin "FOOBAR", "Press return to enter the server as \"FOOBAR\":")+      , (GameCreation 484, "{Game 484 (GuestYLCL vs. GuestBYPB) Creating unrated blitz match.}\n")+      , (AbortRequest "GuestSPLL", "GuestSPLL would like to abort the game; type \"abort\" to accept.")+      , (TakebackRequest "GuestTYLF" 2, "GuestTYLF would like to take back 2 half move(s).")+      , (GameResult 82 "Game aborted by mutual agreement" Aborted, "\NAK5\SYN11\SYNYou accept the abort request from GuestSPLL.\n\n{Game 82 (GuestTKHJ vs. GuestSPLL) Game aborted by mutual agreement} *\n\ETB")+      , (GameResult 112 "Game aborted on move 1" Aborted, "\NAK4\SYN10\SYNThe game has been aborted on move one.\n\n{Game 112 (GuestSPLL vs. GuestTKHJ) Game aborted on move 1} *\n\ETB")+      , (GameResult 383 "Game aborted by mutual agreement" Aborted, "\NAK5\SYN10\SYN\n{Game 383 (GuestRVNY vs. GuestZTNM) Game aborted by mutual agreement} *\n\ETB")+      , (GameResult 112 "Game aborted on move 1" Aborted, "{Game 112 (GuestSPLL vs. GuestTKHJ) Game aborted on move 1} *")+      , (GameResult 297 "Game aborted by mutual agreement" Aborted, "{Game 297 (GuestSPLL vs. GuestTKHJ) Game aborted by mutual agreement} *")+      , (GameResult 10 "Kratt forfeits on time" WhiteWins, "{Game 10 (GidonC vs. Kratt) Kratt forfeits on time} 1-0\n")+      , (GameResult 368 "CalicoCat resigns" WhiteWins, "{Game 368 (ALTOTAS vs. CalicoCat) CalicoCat resigns} 1-0")+      , (GameResult 406 "GuestQLHT resigns" BlackWins, "\n{Game 406 (GuestQLHT vs. GuestVYVJ) GuestQLHT resigns} 0-1\n\nNo ratings adjustment done.")+      , (GameResult 181 "Danimateit forfeits on time" BlackWins, "{Game 181 (Danimateit vs. WhatKnight) Danimateit forfeits on time} 0-1")+      , (GameResult 196 "Game drawn by mutual agreement" Draw, "\NAK4\SYN34\SYN\n{Game 196 (GuestCWVD vs. GuestDWTL) Game drawn by mutual agreement} 1/2-1/2\n\nNo ratings adjustment done.\n\ETB")+      , (GameResult 202 "Game drawn by mutual agreement" Draw, "\NAK5\SYN11\SYNYou accept the draw request from GuestNMNG.\n\n{Game 202 (GuestDKZD vs. GuestNMNG) Game drawn by mutual agreement} 1/2-1/2\n\nNo ratings adjustment done.\n\ETB")+      , (MatchUserNotLoggedIn "GuestLHDG", "\NAK4\SYN73\SYNGuestLHDG is not logged in.\n\ETB")+      , (PieceHolding 455 [Pawn,Rook,Knight] [Bishop,Queen],  "<b1> game 455 white [PRN] black [BQ]")+      , (PieceHolding 182 [Pawn,Pawn,Bishop] [Pawn,Queen,Queen], "<b1> game 182 white [PPB] black [PQQ] <- BQ\n")+      , (SeekNotAvailable, "\NAK4\SYN158\SYNThat seek is not available.\n\ETB")++      , (MatchRequested $ Challenge "Schoon" (R.Rating 997 R.None) "GuestPCFH" R.Unrated "unrated blitz 5 0", "Challenge: Schoon ( 997) GuestPCFH (----) unrated blitz 5 0.\n\r\aYou can \"accept\" or \"decline\", or propose different parameters.")+      , (PromotionPiece Knight, "\NAK5\SYN92\SYNPromotion piece set to KNIGHT.\n\ETB\n")+      , (PromotionPiece Queen, "\NAK5\SYN92\SYNPromotion piece set to QUEEN.\n\ETB\n")+      , (PromotionPiece Bishop, "\NAK5\SYN92\SYNPromotion piece set to BISHOP.\n\ETB\n")+      , (PromotionPiece Rook, "\NAK5\SYN92\SYNPromotion piece set to ROOK.\n\ETB\n")+      , (PromotionPiece King, "\NAK5\SYN92\SYNPromotion piece set to KING.\n\ETB\n") -- Suicide+      ]++defaultMove = Move "-------- -------- -------- -------- -------- -------- -------- --------" [] White Nothing [WhiteShort,WhiteLong,BlackShort,BlackLong] 0 18 "nameWhite" "nameBlack" OponentsMove 3 0 39 39 180 180 1 Nothing "(0:00)" Nothing+defaultMoveStr = "<12> -------- -------- -------- -------- -------- -------- -------- -------- W -1 1 1 1 1 0 18 nameWhite nameBlack -1 3 0 39 39 180 180 1 none (0:00) none 1 0 0\n"++seekMsgParserTest :: Bool+seekMsgParserTest = all (== Pass) $ fmap compareCmdMsg seekMsgParserTestData++seekMsgParserTestData :: [(FicsMessage, String)]+seekMsgParserTestData = [+    (ClearSeek, "<sc>")+  , (RemoveSeeks [59, 3, 11], "<sr> 59 3 11")+  , (NewSeek $ Seek 7 "GuestNMZJ" [Unregistered] (R.Rating 0 R.Provisional) 15 5 False Standard (Just White) (0,9999), "<s> 7 w=GuestNMZJ ti=01 rt=0P t=15 i=5 r=u tp=standard c=W rr=0-9999 a=t f=t")+  , (NewSeek $ Seek 16 "CatNail" [Computer] (R.Rating 1997 R.None) 3 0 False Suicide Nothing (0,9999), "<s> 16 w=CatNail ti=02 rt=1997  t=3 i=0 r=u tp=suicide c=? rr=0-9999 a=f f=f")+  , (NewSeek $ Seek 56 "GuestCXDH" [Unregistered] (R.Rating 0 R.Provisional) 7 0 False Wild (Just White) (0,9999), "<s> 56 w=GuestCXDH ti=01 rt=0P t=7 i=0 r=u tp=wild/4 c=W rr=0-9999 a=t f=f")+  ]+++positionTest :: Bool+positionTest = all (== Pass) $ fmap comparePosition positionTestData+++positionTestData :: [(Position, String)]+positionTestData = [+    ([], "-------- -------- -------- -------- -------- -------- -------- --------")+  , ([ (Square A Eight, Piece Rook White)+     , (Square B Seven, Piece Knight White)+     , (Square C Six, Piece Bishop White)+     , (Square D Five, Piece Queen White)+     , (Square E Four, Piece King White)+     , (Square F Three, Piece Pawn White)+     , (Square G Two, Piece Rook Black)+     , (Square H One, Piece King Black)], "R------- -N------ --B----- ---Q---- ----K--- -----P-- ------r- -------k")+  ]++moveParserTest :: Bool+moveParserTest = all (== Pass) $ fmap withParser moveParserTestData++moveParserTestData :: [(Parser (Maybe MoveDetailed), String, Maybe MoveDetailed)]+moveParserTestData = [+    (verboseMove', "P/c7-c5", Just $ Simple (Square C Seven) (Square C Five))+  , (verboseMove', "P/f2-f1=R", Just $ Simple (Square F Two) (Square F One))+  , (verboseMove', "o-o", Just CastleShort)+  , (verboseMove', "o-o-o", Just CastleLong)+  , (verboseMove', "B/@@-g6", Just $ Drop $ Square G Six)+  ]++{-+parseGamesListTest :: Result+parseGamesListTest = case parseFicsMessage $ BS.pack games of+  Left txt -> Fail txt+  Right (Games games) -> if length games == 584 then Pass else Fail $ show $ length games+  where games = unsafePerformIO $ readFile "./test/Games.txt"+-}++withParser :: (Show a, Eq a) => (Parser a, String, a) -> Result+withParser (parser, str, x) = case parseOnly parser (BS.pack str) of+  Left txt -> Fail txt+  Right x' -> if x' == x then Pass else Fail $ show x ++ " <<==>> " ++ show x'+++comparePosition :: (Position, String) -> Result+comparePosition (pos, str) = let pos' = parsePosition str+                             in if pos' == pos then Pass else Fail $ show pos ++ " <<-->> " ++ show pos'++compareCmdMsg :: (FicsMessage, String) -> Result+compareCmdMsg (cmd, str) = case parseFicsMessage $ BS.pack str of+  Left txt -> Fail txt+  Right cmd' -> if cmd' == cmd then Pass else Fail $ show cmd ++ " <<-->> " ++ show cmd'
+ test/PlayersSpec.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module PlayersSpec (spec) where++import qualified Macbeth.Fics.Api.Rating as R+import Macbeth.Fics.FicsMessage+import Macbeth.Fics.Api.Player+import Macbeth.Fics.Parsers.Players++import Test.Hspec+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8 as BS+++spec :: Spec+spec =+  describe "Players" $ do++    it "single player, Unregistered" $ parseOnly player' "++++^TeachMATE(U)\n"+      `shouldBe` Right (Player R.Guest InvolvedInAGame (UserHandle "TeachMATE" [Unregistered]))++    it "single player 2, with space" $ parseOnly player' "1173.kalithkar  "+      `shouldBe` Right (Player (R.Rating 1173 R.None) InactiveOrBusy (UserHandle "kalithkar" []))++    it "single player, Admin & TournamentDirectorOrBot" $ parseOnly player' "----:adminBOT(*)(TD)"+      `shouldBe` Right (Player R.Unrated NotOpenForMatch (UserHandle "adminBOT" [Admin,ServiceRepresentative]))++    it "players" $ parseOnly players' "\n2985.BigMomma(C)                 ++++ xcx(U)\n1123^littledul                \n\n 1055 players displayed (of 1055). (*) indicates system administrator.\n\ETB"+      `shouldBe` Right [Player (R.Rating 2985 R.None) InactiveOrBusy (UserHandle "BigMomma" [Computer]),Player R.Guest NotBusy (UserHandle "xcx" [Unregistered]),Player (R.Rating 1123 R.None) InvolvedInAGame (UserHandle "littledul" [])]++    it "check num players in block" $ fmap (\(Players x) -> length x) (parseOnly players "\NAK5\SYN146\SYN\n2985.BigMomma(C)                 ++++ xcx(U)\n1123^littledul                \n\n 1055 players displayed (of 1055). (*) indicates system administrator.\n\ETB")+      `shouldBe` Right 3++    it "check num players in block 2" $ fmap (\(Players x) -> length x) (parseOnly players "\NAK5\SYN146\SYN\n2985.BigMomma(C)                 ++++ xcx(U)\n\n 1055 players displayed (of 1055). (*) indicates system administrator.\n\ETB")+      `shouldBe` Right 2++    it "bughouse partner offer" $ parseOnly partnerOffer "GuestZTCG offers to be your bughouse partner; type \"partner GuestZTCG\" to accept.\n"+      `shouldBe` Right (PartnerOffer (UserHandle "GuestZTCG" []))++    it "bughouse partner accepted" $ parseOnly partnerAccepted "GuestCCGS agrees to be your partner.\n"+      `shouldBe` Right (PartnerAccepted (UserHandle "GuestCCGS" []))++    it "bughouse partner declined" $ parseOnly partnerDeclined "GuestCCGS declines the partnership request.\n"+      `shouldBe` Right (PartnerDeclined (UserHandle "GuestCCGS" []))++    it "bughouse partner not open" $ parseOnly partnerNotOpen "\NAK6\SYN84\SYNzerowin is not open for bughouse.\n\ETB\n"+      `shouldBe` Right (PartnerNotOpen (UserHandle "zerowin" []))++    it "finger" $ parseOnly finger "\NAK6\SYN37\SYNFinger of raffa:\n\nOn for: 6 mins   Idle: 13 secs\n(playing  Who knew?\n\ETB\n"+      `shouldBe` Right (Finger (UserHandle "raffa" []) "\n\nOn for: 6 mins   Idle: 13 secs\n(playing  Who knew?\n")++    it "history" $ parseOnly history "\NAK6\SYN51\SYN\nHistory for Guffster:\n                  Opponent      Type         ECO End Date\n76: - 1337 B 1490 vitaliyS      [ br  5   0] B06 Res Wed Feb 10, 18:29 EST 2016\n77: + 1348 W 1466 vitaliyS      [ br  5   0] C23 Mat Wed Feb 10, 18:38 EST 2016\n\ETB"+      `shouldBe` Right (History (UserHandle "Guffster" []) "\n                  Opponent      Type         ECO End Date\n76: - 1337 B 1490 vitaliyS      [ br  5   0] B06 Res Wed Feb 10, 18:29 EST 2016\n77: + 1348 W 1466 vitaliyS      [ br  5   0] C23 Mat Wed Feb 10, 18:38 EST 2016\n")
+ test/SeekSpec.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++module SeekSpec (spec) where++import Macbeth.Fics.Api.Api+import Macbeth.Wx.Seek+import Macbeth.Wx.GameType++import Test.Hspec+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8 as BS++seekInfo :: SeekInfo+seekInfo = SeekInfo {+    _category = Chess+  , _board = Nothing+  , _time = 5+  , _inc = 10+  , _rated = False+  , _color = Nothing+  , _manual = False+  , _ratingFrom = 0+  , _ratingTo = 9999+}+++spec :: Spec+spec =+  describe "Seek widget" $ do++    it "seekInfo to string" $ toString seekInfo `shouldBe` "5 10 u chess a 0-9999"+    it "seekInfo to string, color=white" $ toString seekInfo {_color = Just White} `shouldBe` "5 10 u w chess a 0-9999"+    it "seekInfo to string, color=white" $ toString seekInfo {_rated = True} `shouldBe` "5 10 r chess a 0-9999"+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}