{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
module Game.Chess.Internal.ECO where

import           Control.DeepSeq                   (NFData)
import           Control.Monad.IO.Class            (MonadIO (..))
import           Data.Bifunctor                    (Bifunctor (first))
import           Data.Binary                       (Binary (get, put))
import           Data.ByteString.Char8             (ByteString)
import qualified Data.ByteString.Char8             as BS
import           Data.Char                         (chr, ord)
import           Data.Data                         ()
import           Data.Foldable                     (fold)
import           Data.Functor                      (($>))
import           Data.HashMap.Strict               (HashMap)
import qualified Data.HashMap.Strict               as HashMap
import           Data.Hashable                     (Hashable)
import           Data.Maybe                        (fromMaybe)
import           Data.MonoTraversable              (MonoFoldable (ofoldl'))
import           Data.Text                         (Text)
import qualified Data.Text                         as T
import           Data.Tree                         (foldTree)
import           Data.Vector.Binary                ()
import           Data.Vector.Instances             ()
import qualified Data.Vector.Unboxed               as Unboxed
import           Data.Void                         (Void)
import           Data.Word                         (Word8)
import           GHC.Generics                      (Generic)
import           Game.Chess.Internal               (Ply, Position (moveNumber),
                                                    startpos, unsafeDoPly)
import           Game.Chess.PGN                    (Annotated (_annPly),
                                                    Game (CG, _cgForest, _cgOutcome, _cgTags),
                                                    PGN (..), readPGNFile)
import           Game.Chess.SAN                    (relaxedSAN)
import           Instances.TH.Lift                 ()
import           Language.Haskell.TH.Syntax        (Lift)
import           Language.Haskell.TH.Syntax.Compat (Code,
                                                    IsCode (fromCode, toCode),
                                                    SpliceQ, bindCode, joinCode,
                                                    liftTypedQuote)
import           Prelude                           hiding (lookup)
import qualified Prelude
import           Text.Megaparsec                   (MonadParsec (eof), Parsec,
                                                    anySingleBut,
                                                    errorBundlePretty, many,
                                                    optional, parse, single,
                                                    (<?>), (<|>))
import           Text.Megaparsec.Byte              (alphaNumChar, digitChar,
                                                    space, space1, string)
import qualified Text.Megaparsec.Byte.Lexer        as L

-- | A Chess Opening
data Opening = CO {
  Opening -> Text
coCode      :: !Text
, Opening -> Text
coName      :: !Text
, Opening -> Maybe Text
coVariation :: !(Maybe Text)
, Opening -> Vector Ply
coPlies     :: !(Unboxed.Vector Ply)
} deriving (Opening -> Opening -> Bool
(Opening -> Opening -> Bool)
-> (Opening -> Opening -> Bool) -> Eq Opening
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Opening -> Opening -> Bool
== :: Opening -> Opening -> Bool
$c/= :: Opening -> Opening -> Bool
/= :: Opening -> Opening -> Bool
Eq, (forall x. Opening -> Rep Opening x)
-> (forall x. Rep Opening x -> Opening) -> Generic Opening
forall x. Rep Opening x -> Opening
forall x. Opening -> Rep Opening x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Opening -> Rep Opening x
from :: forall x. Opening -> Rep Opening x
$cto :: forall x. Rep Opening x -> Opening
to :: forall x. Rep Opening x -> Opening
Generic, (forall (m :: * -> *). Quote m => Opening -> m Exp)
-> (forall (m :: * -> *). Quote m => Opening -> Code m Opening)
-> Lift Opening
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Opening -> m Exp
forall (m :: * -> *). Quote m => Opening -> Code m Opening
$clift :: forall (m :: * -> *). Quote m => Opening -> m Exp
lift :: forall (m :: * -> *). Quote m => Opening -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Opening -> Code m Opening
liftTyped :: forall (m :: * -> *). Quote m => Opening -> Code m Opening
Lift, Int -> Opening -> ShowS
[Opening] -> ShowS
Opening -> String
(Int -> Opening -> ShowS)
-> (Opening -> String) -> ([Opening] -> ShowS) -> Show Opening
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Opening -> ShowS
showsPrec :: Int -> Opening -> ShowS
$cshow :: Opening -> String
show :: Opening -> String
$cshowList :: [Opening] -> ShowS
showList :: [Opening] -> ShowS
Show)

instance Binary Opening
instance Hashable Opening
instance NFData Opening

type FileReader = forall m. MonadIO m => FilePath -> m (Either String [Opening])

-- | Parse an ECO database in .pgn format
ecoPgn :: FileReader
ecoPgn :: FileReader
ecoPgn String
fp = (PGN -> [Opening]) -> Either String PGN -> Either String [Opening]
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PGN -> [Opening]
fromPGN' (Either String PGN -> Either String [Opening])
-> m (Either String PGN) -> m (Either String [Opening])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Either String PGN)
forall (m :: * -> *). MonadIO m => String -> m (Either String PGN)
readPGNFile String
fp

-- | Parse an ECO database in .eco format
scidEco :: FileReader
scidEco :: FileReader
scidEco String
fp = (ParseErrorBundle ByteString Void -> String)
-> Either (ParseErrorBundle ByteString Void) [Opening]
-> Either String [Opening]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle ByteString Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (Either (ParseErrorBundle ByteString Void) [Opening]
 -> Either String [Opening])
-> (ByteString
    -> Either (ParseErrorBundle ByteString Void) [Opening])
-> ByteString
-> Either String [Opening]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void ByteString [Opening]
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) [Opening]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void ByteString [Opening]
scid' String
fp (ByteString -> Either String [Opening])
-> m ByteString -> m (Either String [Opening])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BS.readFile String
fp)

-- | Encyclopedia of Chess Openings
newtype ECO = ECO { ECO -> HashMap Position Opening
toHashMap :: HashMap Position Opening }
              deriving (ECO -> ECO -> Bool
(ECO -> ECO -> Bool) -> (ECO -> ECO -> Bool) -> Eq ECO
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ECO -> ECO -> Bool
== :: ECO -> ECO -> Bool
$c/= :: ECO -> ECO -> Bool
/= :: ECO -> ECO -> Bool
Eq, ECO -> ()
(ECO -> ()) -> NFData ECO
forall a. (a -> ()) -> NFData a
$crnf :: ECO -> ()
rnf :: ECO -> ()
NFData, Eq ECO
Eq ECO => (Int -> ECO -> Int) -> (ECO -> Int) -> Hashable ECO
Int -> ECO -> Int
ECO -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> ECO -> Int
hashWithSalt :: Int -> ECO -> Int
$chash :: ECO -> Int
hash :: ECO -> Int
Hashable, NonEmpty ECO -> ECO
ECO -> ECO -> ECO
(ECO -> ECO -> ECO)
-> (NonEmpty ECO -> ECO)
-> (forall b. Integral b => b -> ECO -> ECO)
-> Semigroup ECO
forall b. Integral b => b -> ECO -> ECO
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ECO -> ECO -> ECO
<> :: ECO -> ECO -> ECO
$csconcat :: NonEmpty ECO -> ECO
sconcat :: NonEmpty ECO -> ECO
$cstimes :: forall b. Integral b => b -> ECO -> ECO
stimes :: forall b. Integral b => b -> ECO -> ECO
Semigroup, Semigroup ECO
ECO
Semigroup ECO =>
ECO -> (ECO -> ECO -> ECO) -> ([ECO] -> ECO) -> Monoid ECO
[ECO] -> ECO
ECO -> ECO -> ECO
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: ECO
mempty :: ECO
$cmappend :: ECO -> ECO -> ECO
mappend :: ECO -> ECO -> ECO
$cmconcat :: [ECO] -> ECO
mconcat :: [ECO] -> ECO
Monoid)

instance Binary ECO where
  put :: ECO -> Put
put = [Opening] -> Put
forall t. Binary t => t -> Put
put ([Opening] -> Put) -> (ECO -> [Opening]) -> ECO -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ECO -> [Opening]
toList
  get :: Get ECO
get = [Opening] -> ECO
fromList ([Opening] -> ECO) -> Get [Opening] -> Get ECO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [Opening]
forall t. Binary t => Get t
get

embedECO :: FileReader -> FilePath -> SpliceQ ECO
embedECO :: FileReader -> String -> SpliceQ ECO
embedECO FileReader
load String
fp = SpliceQ ECO -> SpliceQ ECO
forall (q :: * -> *) a c. IsCode q a c => Code q a -> c
fromCode (SpliceQ ECO -> SpliceQ ECO) -> SpliceQ ECO -> SpliceQ ECO
forall a b. (a -> b) -> a -> b
$
  ((Either String [Opening] -> Either String (Code Q [Opening]))
-> Q (Either String [Opening])
-> Q (Either String (Code Q [Opening]))
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Either String [Opening] -> Either String (Code Q [Opening]))
 -> Q (Either String [Opening])
 -> Q (Either String (Code Q [Opening])))
-> (([Opening] -> Code Q [Opening])
    -> Either String [Opening] -> Either String (Code Q [Opening]))
-> ([Opening] -> Code Q [Opening])
-> Q (Either String [Opening])
-> Q (Either String (Code Q [Opening]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Opening] -> Code Q [Opening])
-> Either String [Opening] -> Either String (Code Q [Opening])
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) [Opening] -> Code Q [Opening]
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
liftTypedQuote (String -> Q (Either String [Opening])
FileReader
load String
fp) Q (Either String (Code Q [Opening]))
-> (Either String (Code Q [Opening]) -> SpliceQ ECO) -> SpliceQ ECO
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> Code m b) -> Code m b
`bindCode` \Either String (Code Q [Opening])
x -> Q (SpliceQ ECO) -> SpliceQ ECO
forall (m :: * -> *) a. Monad m => m (Code m a) -> Code m a
joinCode (Q (SpliceQ ECO) -> SpliceQ ECO) -> Q (SpliceQ ECO) -> SpliceQ ECO
forall a b. (a -> b) -> a -> b
$
    case Either String (Code Q [Opening])
x of
      Right Code Q [Opening]
xs -> SpliceQ ECO -> Q (SpliceQ ECO)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpliceQ ECO -> Q (SpliceQ ECO)) -> SpliceQ ECO -> Q (SpliceQ ECO)
forall a b. (a -> b) -> a -> b
$ SpliceQ ECO -> SpliceQ ECO
forall (q :: * -> *) a c. IsCode q a c => c -> Code q a
toCode [|| [Opening] -> ECO
fromList $$(Code Q [Opening] -> Code Q [Opening]
forall (q :: * -> *) a c. IsCode q a c => Code q a -> c
fromCode Code Q [Opening]
xs) ||]
      Left String
err -> String -> Q (SpliceQ ECO)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err

toList :: ECO -> [Opening]
toList :: ECO -> [Opening]
toList = ((Position, Opening) -> Opening)
-> [(Position, Opening)] -> [Opening]
forall a b. (a -> b) -> [a] -> [b]
map (Position, Opening) -> Opening
forall a b. (a, b) -> b
snd ([(Position, Opening)] -> [Opening])
-> (ECO -> [(Position, Opening)]) -> ECO -> [Opening]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Position Opening -> [(Position, Opening)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap Position Opening -> [(Position, Opening)])
-> (ECO -> HashMap Position Opening)
-> ECO
-> [(Position, Opening)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ECO -> HashMap Position Opening
toHashMap

fromList :: [Opening] -> ECO
fromList :: [Opening] -> ECO
fromList = HashMap Position Opening -> ECO
ECO (HashMap Position Opening -> ECO)
-> ([Opening] -> HashMap Position Opening) -> [Opening] -> ECO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Position, Opening)] -> HashMap Position Opening
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Position, Opening)] -> HashMap Position Opening)
-> ([Opening] -> [(Position, Opening)])
-> [Opening]
-> HashMap Position Opening
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Opening -> (Position, Opening))
-> [Opening] -> [(Position, Opening)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Opening
co -> (Opening -> Position
pos Opening
co, Opening
co)) where
  pos :: Opening -> Position
pos = (Position -> Element (Vector Ply) -> Position)
-> Position -> Vector Ply -> Position
forall mono a.
MonoFoldable mono =>
(a -> Element mono -> a) -> a -> mono -> a
forall a. (a -> Element (Vector Ply) -> a) -> a -> Vector Ply -> a
ofoldl' Position -> Element (Vector Ply) -> Position
Position -> Ply -> Position
unsafeDoPly Position
startpos (Vector Ply -> Position)
-> (Opening -> Vector Ply) -> Opening -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Opening -> Vector Ply
coPlies

-- | Convert a PGN database to ECO assuming the ECO, Opening and Variation tags are
-- being used to identify chess openings.
fromPGN :: PGN -> ECO
fromPGN :: PGN -> ECO
fromPGN = [Opening] -> ECO
fromList ([Opening] -> ECO) -> (PGN -> [Opening]) -> PGN -> ECO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGN -> [Opening]
fromPGN'

fromPGN' :: PGN -> [Opening]
fromPGN' :: PGN -> [Opening]
fromPGN' (PGN [Game]
games) = (Game -> Opening) -> [Game] -> [Opening]
forall a b. (a -> b) -> [a] -> [b]
map Game -> Opening
mkCO [Game]
games where
  mkCO :: Game -> Opening
mkCO CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgForest :: Game -> [Tree (Annotated Ply)]
_cgOutcome :: Game -> Outcome
_cgTags :: Game -> [(Text, Text)]
_cgTags :: [(Text, Text)]
_cgForest :: [Tree (Annotated Ply)]
_cgOutcome :: Outcome
.. } = CO { Maybe Text
Text
Vector Ply
coCode :: Text
coName :: Text
coVariation :: Maybe Text
coPlies :: Vector Ply
coCode :: Text
coName :: Text
coVariation :: Maybe Text
coPlies :: Vector Ply
.. } where
    lt :: Text -> Maybe Text
lt = (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`Prelude.lookup` [(Text, Text)]
_cgTags)
    coCode :: Text
coCode = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
lt Text
"ECO"
    coName :: Text
coName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
lt Text
"Opening"
    coVariation :: Maybe Text
coVariation = Text -> Maybe Text
lt Text
"Variation"
    coPlies :: Vector Ply
coPlies = [Ply] -> Vector Ply
forall a. Unbox a => [a] -> Vector a
Unboxed.fromList ([Ply] -> Vector Ply)
-> ([Tree (Annotated Ply)] -> [Ply])
-> [Tree (Annotated Ply)]
-> Vector Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Ply]] -> [Ply]
forall a. HasCallStack => [a] -> a
head ([[Ply]] -> [Ply])
-> ([Tree (Annotated Ply)] -> [[Ply]])
-> [Tree (Annotated Ply)]
-> [Ply]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (Annotated Ply) -> [[Ply]])
-> [Tree (Annotated Ply)] -> [[Ply]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Annotated Ply -> [[[Ply]]] -> [[Ply]])
-> Tree (Annotated Ply) -> [[Ply]]
forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree Annotated Ply -> [[[Ply]]] -> [[Ply]]
forall {a}. Annotated a -> [[[a]]] -> [[a]]
g) ([Tree (Annotated Ply)] -> Vector Ply)
-> [Tree (Annotated Ply)] -> Vector Ply
forall a b. (a -> b) -> a -> b
$ [Tree (Annotated Ply)]
_cgForest where
      g :: Annotated a -> [[[a]]] -> [[a]]
g Annotated a
a [] = [[Annotated a -> a
forall a. Annotated a -> a
_annPly Annotated a
a]]
      g Annotated a
a [[[a]]]
xs = (Annotated a -> a
forall a. Annotated a -> a
_annPly Annotated a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> [[a]] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[[a]]] -> [[a]]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [[[a]]]
xs

opening :: Parser Opening
opening :: Parser Opening
opening = Text -> Text -> Maybe Text -> Vector Ply -> Opening
CO (Text -> Text -> Maybe Text -> Vector Ply -> Opening)
-> ParsecT Void ByteString Identity Text
-> ParsecT
     Void
     ByteString
     Identity
     (Text -> Maybe Text -> Vector Ply -> Opening)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity Text
-> ParsecT Void ByteString Identity Text
forall a. Parser a -> Parser a
lexeme ParsecT Void ByteString Identity Text
code ParsecT
  Void
  ByteString
  Identity
  (Text -> Maybe Text -> Vector Ply -> Opening)
-> ParsecT Void ByteString Identity Text
-> ParsecT
     Void ByteString Identity (Maybe Text -> Vector Ply -> Opening)
forall a b.
ParsecT Void ByteString Identity (a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void ByteString Identity Text
-> ParsecT Void ByteString Identity Text
forall a. Parser a -> Parser a
lexeme ParsecT Void ByteString Identity Text
var ParsecT
  Void ByteString Identity (Maybe Text -> Vector Ply -> Opening)
-> ParsecT Void ByteString Identity (Maybe Text)
-> ParsecT Void ByteString Identity (Vector Ply -> Opening)
forall a b.
ParsecT Void ByteString Identity (a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> ParsecT Void ByteString Identity (Maybe Text)
forall a. a -> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing ParsecT Void ByteString Identity (Vector Ply -> Opening)
-> ParsecT Void ByteString Identity (Vector Ply) -> Parser Opening
forall a b.
ParsecT Void ByteString Identity (a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void ByteString Identity (Vector Ply)
-> ParsecT Void ByteString Identity (Vector Ply)
forall a. Parser a -> Parser a
lexeme (Position -> ParsecT Void ByteString Identity (Vector Ply)
plies Position
startpos)

code :: Parser Text
code :: ParsecT Void ByteString Identity Text
code = ParsecT Void ByteString Identity Text
p ParsecT Void ByteString Identity Text
-> String -> ParsecT Void ByteString Identity Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"code" where
  p :: ParsecT Void ByteString Identity Text
p = Word8 -> [Word8] -> Maybe Word8 -> Text
forall {a}. Enum a => a -> [a] -> Maybe a -> Text
f (Word8 -> [Word8] -> Maybe Word8 -> Text)
-> ParsecT Void ByteString Identity Word8
-> ParsecT
     Void ByteString Identity ([Word8] -> Maybe Word8 -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity Word8
ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
alphaNumChar ParsecT Void ByteString Identity ([Word8] -> Maybe Word8 -> Text)
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity (Maybe Word8 -> Text)
forall a b.
ParsecT Void ByteString Identity (a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void ByteString Identity Word8
ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
digitChar ParsecT Void ByteString Identity (Maybe Word8 -> Text)
-> ParsecT Void ByteString Identity (Maybe Word8)
-> ParsecT Void ByteString Identity Text
forall a b.
ParsecT Void ByteString Identity (a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity (Maybe Word8)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void ByteString Identity Word8
ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
alphaNumChar
  f :: a -> [a] -> Maybe a -> Text
f a
x [a]
xs Maybe a
y = let s :: [a]
s = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs in String -> Text
T.pack (String -> Text) -> ([a] -> String) -> [a] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Char) -> [a] -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char
chr (Int -> Char) -> (a -> Int) -> a -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum) ([a] -> Text) -> [a] -> Text
forall a b. (a -> b) -> a -> b
$ case Maybe a
y of
    Maybe a
Nothing -> [a]
s
    Just a
y' -> [a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
y']

var :: Parser Text
var :: ParsecT Void ByteString Identity Text
var = ParsecT Void ByteString Identity Text
p ParsecT Void ByteString Identity Text
-> String -> ParsecT Void ByteString Identity Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"string" where
  p :: ParsecT Void ByteString Identity Text
p = ([Word8] -> Text)
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity Text
forall a b.
(a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack (String -> Text) -> ([Word8] -> String) -> [Word8] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum)) (ParsecT Void ByteString Identity [Word8]
 -> ParsecT Void ByteString Identity Text)
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity Text
forall a b. (a -> b) -> a -> b
$ Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
quoteChar ParsecT Void ByteString Identity (Token ByteString)
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity [Word8]
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void ByteString Identity Word8
ch ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity (Token ByteString)
-> ParsecT Void ByteString Identity [Word8]
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
quoteChar
  ch :: ParsecT Void ByteString Identity Word8
ch = Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
backslashChar ParsecT Void ByteString Identity (Token ByteString)
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (  Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
backslashChar ParsecT Void ByteString Identity (Token ByteString)
-> Word8 -> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word8
backslashChar
                              ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
quoteChar ParsecT Void ByteString Identity (Token ByteString)
-> Word8 -> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word8
quoteChar
                               )
    ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
anySingleBut Word8
Token ByteString
quoteChar

plies :: Position -> Parser (Unboxed.Vector Ply)
plies :: Position -> ParsecT Void ByteString Identity (Vector Ply)
plies = ([Ply] -> Vector Ply)
-> ParsecT Void ByteString Identity [Ply]
-> ParsecT Void ByteString Identity (Vector Ply)
forall a b.
(a -> b)
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Ply] -> Vector Ply
forall a. Unbox a => [a] -> Vector a
Unboxed.fromList (ParsecT Void ByteString Identity [Ply]
 -> ParsecT Void ByteString Identity (Vector Ply))
-> (Position -> ParsecT Void ByteString Identity [Ply])
-> Position
-> ParsecT Void ByteString Identity (Vector Ply)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> ParsecT Void ByteString Identity [Ply]
go where
  go :: Position -> ParsecT Void ByteString Identity [Ply]
go Position
p = ParsecT Void ByteString Identity [Ply]
forall {a}. ParsecT Void ByteString Identity [a]
eol ParsecT Void ByteString Identity [Ply]
-> ParsecT Void ByteString Identity [Ply]
-> ParsecT Void ByteString Identity [Ply]
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void ByteString Identity [Ply]
line where
    eol :: ParsecT Void ByteString Identity [a]
eol = Parser (Tokens ByteString) -> Parser (Tokens ByteString)
forall a. Parser a -> Parser a
lexeme (Tokens ByteString -> Parser (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"*") Parser (Tokens ByteString)
-> [a] -> ParsecT Void ByteString Identity [a]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
    line :: ParsecT Void ByteString Identity [Ply]
line = ParsecT Void ByteString Identity Ply
ply ParsecT Void ByteString Identity Ply
-> (Ply -> ParsecT Void ByteString Identity [Ply])
-> ParsecT Void ByteString Identity [Ply]
forall a b.
ParsecT Void ByteString Identity a
-> (a -> ParsecT Void ByteString Identity b)
-> ParsecT Void ByteString Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ply
pl -> (Ply
pl Ply -> [Ply] -> [Ply]
forall a. a -> [a] -> [a]
:) ([Ply] -> [Ply])
-> ParsecT Void ByteString Identity [Ply]
-> ParsecT Void ByteString Identity [Ply]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position -> ParsecT Void ByteString Identity [Ply]
go (Position -> Ply -> Position
unsafeDoPly Position
p Ply
pl)
    ply :: ParsecT Void ByteString Identity Ply
ply = Position -> ParsecT Void ByteString Identity ()
validateMoveNumber Position
p ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Ply
-> ParsecT Void ByteString Identity Ply
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void ByteString Identity Ply
-> ParsecT Void ByteString Identity Ply
forall a. Parser a -> Parser a
lexeme (Position -> ParsecT Void ByteString Identity Ply
forall s.
(Stream s, SANToken (Token s), IsString (Tokens s)) =>
Position -> Parser s Ply
relaxedSAN Position
p)
  validateMoveNumber :: Position -> ParsecT Void ByteString Identity ()
validateMoveNumber Position
p =
    ParsecT Void ByteString Identity Int
-> ParsecT Void ByteString Identity (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void ByteString Identity Int
-> ParsecT Void ByteString Identity Int
forall a. Parser a -> Parser a
lexeme (ParsecT Void ByteString Identity Int
 -> ParsecT Void ByteString Identity Int)
-> ParsecT Void ByteString Identity Int
-> ParsecT Void ByteString Identity Int
forall a b. (a -> b) -> a -> b
$ ParsecT Void ByteString Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
L.decimal ParsecT Void ByteString Identity Int
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Int
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space ParsecT Void ByteString Identity Int
-> ParsecT Void ByteString Identity [Token ByteString]
-> ParsecT Void ByteString Identity Int
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity (Token ByteString)
-> ParsecT Void ByteString Identity [Token ByteString]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
periodChar)) ParsecT Void ByteString Identity (Maybe Int)
-> (Maybe Int -> ParsecT Void ByteString Identity ())
-> ParsecT Void ByteString Identity ()
forall a b.
ParsecT Void ByteString Identity a
-> (a -> ParsecT Void ByteString Identity b)
-> ParsecT Void ByteString Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Int
n | Position -> Int
moveNumber Position
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n ->
        String -> ParsecT Void ByteString Identity ()
forall a. String -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void ByteString Identity ())
-> String -> ParsecT Void ByteString Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid move number: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" /= " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Position -> Int
moveNumber Position
p)
      Maybe Int
_ -> () -> ParsecT Void ByteString Identity ()
forall a. a -> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A parser for opening databases in SCID .eco format
scid :: Parser ECO
scid :: Parser ECO
scid = [Opening] -> ECO
fromList ([Opening] -> ECO)
-> Parsec Void ByteString [Opening] -> Parser ECO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void ByteString [Opening]
scid'

scid' :: Parser [Opening]
scid' :: Parsec Void ByteString [Opening]
scid' = ParsecT Void ByteString Identity ()
spaceConsumer ParsecT Void ByteString Identity ()
-> Parsec Void ByteString [Opening]
-> Parsec Void ByteString [Opening]
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Opening -> Parsec Void ByteString [Opening]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Opening
opening Parsec Void ByteString [Opening]
-> ParsecT Void ByteString Identity ()
-> Parsec Void ByteString [Opening]
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

readECOPGNFile :: MonadIO m => FilePath -> m (Either String ECO)
readECOPGNFile :: forall (m :: * -> *). MonadIO m => String -> m (Either String ECO)
readECOPGNFile = ((Either String [Opening] -> Either String ECO)
-> m (Either String [Opening]) -> m (Either String ECO)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either String [Opening] -> Either String ECO)
 -> m (Either String [Opening]) -> m (Either String ECO))
-> (([Opening] -> ECO)
    -> Either String [Opening] -> Either String ECO)
-> ([Opening] -> ECO)
-> m (Either String [Opening])
-> m (Either String ECO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Opening] -> ECO) -> Either String [Opening] -> Either String ECO
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) [Opening] -> ECO
fromList (m (Either String [Opening]) -> m (Either String ECO))
-> (String -> m (Either String [Opening]))
-> String
-> m (Either String ECO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Either String [Opening])
FileReader
ecoPgn

readSCIDECOFile :: MonadIO m => FilePath -> m (Either String ECO)
readSCIDECOFile :: forall (m :: * -> *). MonadIO m => String -> m (Either String ECO)
readSCIDECOFile = ((Either String [Opening] -> Either String ECO)
-> m (Either String [Opening]) -> m (Either String ECO)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either String [Opening] -> Either String ECO)
 -> m (Either String [Opening]) -> m (Either String ECO))
-> (([Opening] -> ECO)
    -> Either String [Opening] -> Either String ECO)
-> ([Opening] -> ECO)
-> m (Either String [Opening])
-> m (Either String ECO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Opening] -> ECO) -> Either String [Opening] -> Either String ECO
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) [Opening] -> ECO
fromList (m (Either String [Opening]) -> m (Either String ECO))
-> (String -> m (Either String [Opening]))
-> String
-> m (Either String ECO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Either String [Opening])
FileReader
scidEco

-- | Retrieve the opening for a particular position
lookup :: Position -> ECO -> Maybe Opening
lookup :: Position -> ECO -> Maybe Opening
lookup Position
pos = Position -> HashMap Position Opening -> Maybe Opening
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Position
pos (HashMap Position Opening -> Maybe Opening)
-> (ECO -> HashMap Position Opening) -> ECO -> Maybe Opening
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ECO -> HashMap Position Opening
toHashMap

type Parser = Parsec Void ByteString

spaceConsumer :: Parser ()
spaceConsumer :: ParsecT Void ByteString Identity ()
spaceConsumer = ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
  ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space1 (Tokens ByteString -> ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Tokens s -> m ()
L.skipLineComment Tokens ByteString
"#") (Tokens ByteString
-> Tokens ByteString -> ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens ByteString
"{" Tokens ByteString
"}")

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme ParsecT Void ByteString Identity ()
spaceConsumer

periodChar, quoteChar, backslashChar :: Word8
periodChar :: Word8
periodChar    = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'.'
quoteChar :: Word8
quoteChar     = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'"'
backslashChar :: Word8
backslashChar = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'\\'