{-# LANGUAGE CPP #-}
module BishBosh.ContextualNotation.PGN(
Tag,
IsStrictlySequential,
PGN(
getMaybeRoundName,
getIdentificationTagPairs,
getGame
),
quoteDelimiter,
unknownTagValue,
dateTag,
showsDate,
showsMoveText,
showsGame,
moveTextParser,
parser,
mkPGN,
mkPGN',
setGame
) where
import Control.Arrow((&&&), (***))
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.ContextualNotation.PGNComment as ContextualNotation.PGNComment
import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason
import qualified BishBosh.Model.Result as Model.Result
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Types as T
import qualified Control.Applicative
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Char
import qualified Data.Default
import qualified Data.List
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Time.Calendar
import qualified Data.Time.Clock
import qualified Text.Printf
#ifdef USE_POLYPARSE
import qualified BishBosh.Text.Poly as Text.Poly
#if USE_POLYPARSE == 1
import qualified Text.ParserCombinators.Poly.Lazy as Poly
#else /* Plain */
import qualified Text.ParserCombinators.Poly.Plain as Poly
#endif
#else /* Parsec */
import qualified BishBosh.Data.Integral as Data.Integral
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec((<?>), (<|>))
#endif
tagPairDelimiters :: (Char, Char)
tagPairDelimiters :: (Char, Char)
tagPairDelimiters = (Char
'[', Char
']')
ravDelimiters :: (Char, Char)
ravDelimiters :: (Char, Char)
ravDelimiters = (Char
'(', Char
')')
inProgressFlag :: Char
inProgressFlag :: Char
inProgressFlag = Char
'*'
nagPrefix :: Char
nagPrefix :: Char
nagPrefix = Char
'$'
moveNumberTerminator :: Char
moveNumberTerminator :: Char
moveNumberTerminator = Char
'.'
quoteDelimiter :: Char
quoteDelimiter :: Char
quoteDelimiter = Char
'"'
dateComponentSeparator :: Char
dateComponentSeparator :: Char
dateComponentSeparator = Char
'.'
unknownTagValue :: Char
unknownTagValue :: Char
unknownTagValue = Char
'?'
type Tag = String
type Value = String
type TagPair = (Tag, Value)
type IsStrictlySequential = Bool
eventNameTag :: Tag
eventNameTag :: Tag
eventNameTag = Tag
"Event"
siteNameTag :: Tag
siteNameTag :: Tag
siteNameTag = Tag
"Site"
dateTag :: Tag
dateTag :: Tag
dateTag = Tag
"Date"
roundNameTag :: Tag
roundNameTag :: Tag
roundNameTag = Tag
"Round"
whitePlayerNameTag :: Tag
whitePlayerNameTag :: Tag
whitePlayerNameTag = Tag
"White"
blackPlayerNameTag :: Tag
blackPlayerNameTag :: Tag
blackPlayerNameTag = Tag
"Black"
resultTag :: Tag
resultTag :: Tag
resultTag = Tag
"Result"
showsDate :: Data.Time.Calendar.Day -> ShowS
showsDate :: Day -> ShowS
showsDate = (
\(Integer
y, Int
m, Int
d) -> Tag -> ShowS
forall a. Show a => a -> ShowS
shows (Tag -> Integer -> Int -> Int -> Tag
forall r. PrintfType r => Tag -> r
Text.Printf.printf Tag
"%04d.%02d.%02d" Integer
y Int
m Int
d :: String)
) ((Integer, Int, Int) -> ShowS)
-> (Day -> (Integer, Int, Int)) -> Day -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
Data.Time.Calendar.toGregorian
data PGN x y = MkPGN {
PGN x y -> Maybe Tag
getMaybeEventName :: Maybe Value,
PGN x y -> Maybe Tag
getMaybeSiteName :: Maybe Value,
PGN x y -> Day
getDay :: Data.Time.Calendar.Day,
PGN x y -> Maybe Tag
getMaybeRoundName :: Maybe Value,
PGN x y -> Maybe Tag
getMaybeWhitePlayerName :: Maybe Value,
PGN x y -> Maybe Tag
getMaybeBlackPlayerName :: Maybe Value,
PGN x y -> [TagPair]
getIdentificationTagPairs :: [TagPair],
PGN x y -> Game x y
getGame :: Model.Game.Game x y
} deriving PGN x y -> PGN x y -> Bool
(PGN x y -> PGN x y -> Bool)
-> (PGN x y -> PGN x y -> Bool) -> Eq (PGN x y)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
PGN x y -> PGN x y -> Bool
/= :: PGN x y -> PGN x y -> Bool
$c/= :: forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
PGN x y -> PGN x y -> Bool
== :: PGN x y -> PGN x y -> Bool
$c== :: forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
PGN x y -> PGN x y -> Bool
Eq
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Show (PGN x y) where
{-# SPECIALISE instance Show (PGN T.X T.Y) #-}
showsPrec :: Int -> PGN x y -> ShowS
showsPrec Int
_ MkPGN {
getMaybeEventName :: forall x y. PGN x y -> Maybe Tag
getMaybeEventName = Maybe Tag
maybeEventName,
getMaybeSiteName :: forall x y. PGN x y -> Maybe Tag
getMaybeSiteName = Maybe Tag
maybeSiteName,
getDay :: forall x y. PGN x y -> Day
getDay = Day
day,
getMaybeRoundName :: forall x y. PGN x y -> Maybe Tag
getMaybeRoundName = Maybe Tag
maybeRoundName,
getMaybeWhitePlayerName :: forall x y. PGN x y -> Maybe Tag
getMaybeWhitePlayerName = Maybe Tag
maybeWhitePlayerName,
getMaybeBlackPlayerName :: forall x y. PGN x y -> Maybe Tag
getMaybeBlackPlayerName = Maybe Tag
maybeBlackPlayerName,
getIdentificationTagPairs :: forall x y. PGN x y -> [TagPair]
getIdentificationTagPairs = [TagPair]
identificationTagPairs,
getGame :: forall x y. PGN x y -> Game x y
getGame = Game x y
game
} = ((Tag, ShowS) -> ShowS -> ShowS)
-> ShowS -> [(Tag, ShowS)] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (
\(Tag
tagName, ShowS
showsTagValue) ShowS
accum -> Char -> ShowS
showChar ((Char, Char) -> Char
forall a b. (a, b) -> a
fst (Char, Char)
tagPairDelimiters) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
tagName ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsTagValue ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ((Char, Char) -> Char
forall a b. (a, b) -> b
snd (Char, Char)
tagPairDelimiters) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
accum
) (
Game x y -> ShowS
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Game x y -> ShowS
showsMoveText Game x y
game ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n'
) ([(Tag, ShowS)] -> ShowS) -> [(Tag, ShowS)] -> ShowS
forall a b. (a -> b) -> a -> b
$ [
(
Tag
eventNameTag, Maybe Tag -> ShowS
representUnknownTagValue Maybe Tag
maybeEventName
), (
Tag
siteNameTag, Maybe Tag -> ShowS
representUnknownTagValue Maybe Tag
maybeSiteName
), (
Tag
dateTag, Day -> ShowS
showsDate Day
day
), (
Tag
roundNameTag, Maybe Tag -> ShowS
representUnknownTagValue Maybe Tag
maybeRoundName
), (
Tag
whitePlayerNameTag, Maybe Tag -> ShowS
representUnknownTagValue Maybe Tag
maybeWhitePlayerName
), (
Tag
blackPlayerNameTag, Maybe Tag -> ShowS
representUnknownTagValue Maybe Tag
maybeBlackPlayerName
), (
Tag
resultTag, ShowS -> ShowS
quote (ShowS -> ShowS)
-> (Maybe GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
-> (GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason
-> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (Char -> ShowS
showChar Char
inProgressFlag) (Result -> ShowS
forall a. Show a => a -> ShowS
shows (Result -> ShowS)
-> (GameTerminationReason -> Result)
-> GameTerminationReason
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameTerminationReason -> Result
Model.GameTerminationReason.toResult) (Maybe GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason -> ShowS
forall a b. (a -> b) -> a -> b
$ Game x y -> Maybe GameTerminationReason
forall x y. Game x y -> Maybe GameTerminationReason
Model.Game.getMaybeTerminationReason Game x y
game
)
] [(Tag, ShowS)] -> [(Tag, ShowS)] -> [(Tag, ShowS)]
forall a. [a] -> [a] -> [a]
++ (TagPair -> (Tag, ShowS)) -> [TagPair] -> [(Tag, ShowS)]
forall a b. (a -> b) -> [a] -> [b]
map (
(Tag -> ShowS) -> TagPair -> (Tag, ShowS)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Control.Arrow.second ((Tag -> ShowS) -> TagPair -> (Tag, ShowS))
-> (Tag -> ShowS) -> TagPair -> (Tag, ShowS)
forall a b. (a -> b) -> a -> b
$ ShowS -> ShowS
quote (ShowS -> ShowS) -> (Tag -> ShowS) -> Tag -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString
) [TagPair]
identificationTagPairs where
quote :: ShowS -> ShowS
quote :: ShowS -> ShowS
quote ShowS
s = Char -> ShowS
showChar Char
quoteDelimiter ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
quoteDelimiter
representUnknownTagValue :: Maybe Value -> ShowS
representUnknownTagValue :: Maybe Tag -> ShowS
representUnknownTagValue = ShowS -> ShowS
quote (ShowS -> ShowS) -> (Maybe Tag -> ShowS) -> Maybe Tag -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (Tag -> ShowS) -> Maybe Tag -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (Char -> ShowS
showChar Char
unknownTagValue) Tag -> ShowS
showString
instance (
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y
) => Control.DeepSeq.NFData (PGN x y) where
rnf :: PGN x y -> ()
rnf MkPGN {
getIdentificationTagPairs :: forall x y. PGN x y -> [TagPair]
getIdentificationTagPairs = [TagPair]
identificationTagPairs,
getGame :: forall x y. PGN x y -> Game x y
getGame = Game x y
game
} = ([TagPair], Game x y) -> ()
forall a. NFData a => a -> ()
Control.DeepSeq.rnf ([TagPair]
identificationTagPairs, Game x y
game)
mkPGN
:: Maybe Value
-> Maybe Value
-> Data.Time.Calendar.Day
-> Maybe Value
-> Maybe Value
-> Maybe Value
-> [TagPair]
-> Model.Game.Game x y
-> PGN x y
mkPGN :: Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game x y
-> PGN x y
mkPGN Maybe Tag
maybeEventName Maybe Tag
maybeSiteName Day
day Maybe Tag
maybeRoundName Maybe Tag
maybeWhitePlayerName Maybe Tag
maybeBlackPlayerName [TagPair]
identificationTagPairs Game x y
game
| (TagPair -> Bool) -> [TagPair] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (
(Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== [Char
unknownTagValue]) (Tag -> Bool) -> (TagPair -> Tag) -> TagPair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagPair -> Tag
forall a b. (a, b) -> b
snd
) [TagPair]
explicitTags = Exception -> PGN x y
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> PGN x y) -> (Tag -> Exception) -> Tag -> PGN x y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Exception
Data.Exception.mkInvalidDatum (Tag -> Exception) -> ShowS -> Tag -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
"BishBosh.ContextualNotation.PGN.mkPGN:\tunknownTagValue" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
forall a. Show a => a -> ShowS
shows Char
unknownTagValue ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
" used literally; " (Tag -> PGN x y) -> Tag -> PGN x y
forall a b. (a -> b) -> a -> b
$ [TagPair] -> Tag
forall a. Show a => a -> Tag
show [TagPair]
explicitTags
| Bool
otherwise = MkPGN :: forall x y.
Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game x y
-> PGN x y
MkPGN {
getMaybeEventName :: Maybe Tag
getMaybeEventName = Maybe Tag
maybeEventName,
getMaybeSiteName :: Maybe Tag
getMaybeSiteName = Maybe Tag
maybeSiteName,
getDay :: Day
getDay = Day
day,
getMaybeRoundName :: Maybe Tag
getMaybeRoundName = Maybe Tag
maybeRoundName,
getMaybeWhitePlayerName :: Maybe Tag
getMaybeWhitePlayerName = Maybe Tag
maybeWhitePlayerName,
getMaybeBlackPlayerName :: Maybe Tag
getMaybeBlackPlayerName = Maybe Tag
maybeBlackPlayerName,
getIdentificationTagPairs :: [TagPair]
getIdentificationTagPairs = [TagPair]
identificationTagPairs,
getGame :: Game x y
getGame = Game x y
game
}
where
explicitTags :: [TagPair]
explicitTags = [
(Tag
tag, Tag
value) |
(Tag
tag, Just Tag
value) <- [
(
Tag
eventNameTag, Maybe Tag
maybeEventName
), (
Tag
siteNameTag, Maybe Tag
maybeSiteName
), (
Tag
whitePlayerNameTag, Maybe Tag
maybeWhitePlayerName
), (
Tag
blackPlayerNameTag, Maybe Tag
maybeBlackPlayerName
)
]
]
setGame :: Model.Game.Game x y -> PGN x y -> PGN x y
setGame :: Game x y -> PGN x y -> PGN x y
setGame Game x y
game PGN x y
pgn = PGN x y
pgn { getGame :: Game x y
getGame = Game x y
game }
mkPGN'
:: [Tag]
-> [TagPair]
-> Model.Game.Game x y
-> PGN x y
mkPGN' :: [Tag] -> [TagPair] -> Game x y -> PGN x y
mkPGN' [Tag]
identificationTags [TagPair]
tagPairs = Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game x y
-> PGN x y
forall x y.
Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game x y
-> PGN x y
mkPGN Maybe Tag
maybeEventName Maybe Tag
maybeSiteName (
let
#ifdef USE_POLYPARSE
dateParser :: Text.Poly.TextParser Data.Time.Calendar.Day
dateParser :: TextParser Day
dateParser = do
[Int
y, Int
m, Int
d] <- TextParser ()
Text.Poly.spaces TextParser () -> Parser Char [Int] -> Parser Char [Int]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char Int -> TextParser () -> Parser Char [Int]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
Poly.sepBy1 Parser Char Int
forall i. Num i => TextParser i
Text.Poly.unsignedDecimal (Char -> TextParser ()
Text.Poly.char Char
dateComponentSeparator)
Day -> TextParser Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> TextParser Day) -> Day -> TextParser Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
Data.Time.Calendar.fromGregorian (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) Int
m Int
d
in Day -> (Tag -> Day) -> Maybe Tag -> Day
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
Exception -> Day
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> Day) -> (Tag -> Exception) -> Tag -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Exception
Data.Exception.mkSearchFailure (Tag -> Exception) -> ShowS -> Tag -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
"failed to find " (Tag -> Day) -> Tag -> Day
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> Tag
show Tag
dateTag
) (
#if USE_POLYPARSE != 1
either (
Control.Exception.throw . Data.Exception.mkParseFailure . showString "failed to parse " . shows dateTag . showString "; " . show
) id .
#endif
(Day, Tag) -> Day
forall a b. (a, b) -> a
fst ((Day, Tag) -> Day) -> (Tag -> (Day, Tag)) -> Tag -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextParser Day -> Tag -> (Day, Tag)
forall t a. Parser t a -> [t] -> (a, [t])
Poly.runParser TextParser Day
dateParser
#else /* Parsec */
dateParser :: Parsec.Parser Data.Time.Calendar.Day
dateParser = do
[y, m, d] <- Parsec.spaces >> (Parsec.sepBy1 (Control.Applicative.some Parsec.digit) (Parsec.char dateComponentSeparator) <?> "YYYY.MM.DD")
return $ Data.Time.Calendar.fromGregorian (read y) (read m) (read d)
in Data.Maybe.maybe (
Control.Exception.throw . Data.Exception.mkSearchFailure . showString "failed to find " $ show dateTag
) (
either (
Control.Exception.throw . Data.Exception.mkParseFailure . showString "failed to parse " . shows dateTag . showString "; " . show
) id . Parsec.parse dateParser "Date-parser"
#endif
) Maybe Tag
maybeDate
) Maybe Tag
maybeRoundName Maybe Tag
maybeWhitePlayerName Maybe Tag
maybeBlackPlayerName ([TagPair] -> Game x y -> PGN x y)
-> [TagPair] -> Game x y -> PGN x y
forall a b. (a -> b) -> a -> b
$ (TagPair -> Bool) -> [TagPair] -> [TagPair]
forall a. (a -> Bool) -> [a] -> [a]
filter (
(Tag -> [Tag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Tag]
identificationTags) (Tag -> Bool) -> (TagPair -> Tag) -> TagPair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagPair -> Tag
forall a b. (a, b) -> a
fst
) [TagPair]
tagPairs where
[Maybe Tag
maybeEventName, Maybe Tag
maybeSiteName, Maybe Tag
maybeDate, Maybe Tag
maybeRoundName, Maybe Tag
maybeWhitePlayerName, Maybe Tag
maybeBlackPlayerName] = (Tag -> Maybe Tag) -> [Tag] -> [Maybe Tag]
forall a b. (a -> b) -> [a] -> [b]
map (
Tag -> Map Tag Tag -> Maybe Tag
forall k a. Ord k => k -> Map k a -> Maybe a
`Data.Map.lookup` [TagPair] -> Map Tag Tag
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList [TagPair]
tagPairs
) [
Tag
eventNameTag,
Tag
siteNameTag,
Tag
dateTag,
Tag
roundNameTag,
Tag
whitePlayerNameTag,
Tag
blackPlayerNameTag
]
showsMoveText :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> ShowS
{-# SPECIALISE showsMoveText :: Model.Game.Game T.X T.Y -> ShowS #-}
showsMoveText :: Game x y -> ShowS
showsMoveText Game x y
game = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (
ShowS
-> (GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason
-> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
Tag -> ShowS
showsBlockComment Tag
"Game unfinished" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
inProgressFlag
) (
(
\(Tag
s, ShowS
showsPGN) -> Tag -> ShowS
showsBlockComment Tag
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsPGN
) ((Tag, ShowS) -> ShowS)
-> (GameTerminationReason -> (Tag, ShowS))
-> GameTerminationReason
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
(Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
ContextualNotation.PGNComment.blockCommentEnd) ShowS
-> (GameTerminationReason -> Tag) -> GameTerminationReason -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameTerminationReason -> Tag
forall a. Show a => a -> Tag
show (GameTerminationReason -> Tag)
-> (GameTerminationReason -> ShowS)
-> GameTerminationReason
-> (Tag, ShowS)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Result -> ShowS
forall a. Show a => a -> ShowS
shows (Result -> ShowS)
-> (GameTerminationReason -> Result)
-> GameTerminationReason
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameTerminationReason -> Result
Model.GameTerminationReason.toResult
)
) (Maybe GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason -> ShowS
forall a b. (a -> b) -> a -> b
$ Game x y -> Maybe GameTerminationReason
forall x y. Game x y -> Maybe GameTerminationReason
Model.Game.getMaybeTerminationReason Game x y
game
) ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ ((Int, [ShowS]) -> Maybe (ShowS, (Int, [ShowS])))
-> (Int, [ShowS]) -> [ShowS]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
Data.List.unfoldr (
\(Int
moveNumber, [ShowS]
turns) -> case [ShowS]
turns of
ShowS
showsWhiteMove : [ShowS]
remainder -> (ShowS, (Int, [ShowS])) -> Maybe (ShowS, (Int, [ShowS]))
forall a. a -> Maybe a
Just ((ShowS, (Int, [ShowS])) -> Maybe (ShowS, (Int, [ShowS])))
-> (([ShowS], [ShowS]) -> (ShowS, (Int, [ShowS])))
-> ([ShowS], [ShowS])
-> Maybe (ShowS, (Int, [ShowS]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
(
\[ShowS]
moveList -> Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
moveNumber ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
moveNumberTerminator ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsWhiteMove ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (ShowS -> ShowS) -> Maybe ShowS -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe ShowS
forall a. a -> a
id (
\ShowS
showsBlackMove -> Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsBlackMove
) (
[ShowS] -> Maybe ShowS
forall a. [a] -> Maybe a
Data.Maybe.listToMaybe [ShowS]
moveList
) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
) ([ShowS] -> ShowS)
-> ([ShowS] -> (Int, [ShowS]))
-> ([ShowS], [ShowS])
-> (ShowS, (Int, [ShowS]))
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (,) (Int -> Int
forall a. Enum a => a -> a
succ Int
moveNumber)
) (([ShowS], [ShowS]) -> Maybe (ShowS, (Int, [ShowS])))
-> ([ShowS], [ShowS]) -> Maybe (ShowS, (Int, [ShowS]))
forall a b. (a -> b) -> a -> b
$ Int -> [ShowS] -> ([ShowS], [ShowS])
forall a. Int -> [a] -> ([a], [a])
Data.List.splitAt Int
1 [ShowS]
remainder
[ShowS]
_ -> Maybe (ShowS, (Int, [ShowS]))
forall a. Maybe a
Nothing
) (
Int
1 :: Component.Move.NMoves,
[ShowS] -> [ShowS]
forall a. [a] -> [a]
reverse ([ShowS] -> [ShowS]) -> [ShowS] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ ([ShowS], Game x y) -> [ShowS]
forall a b. (a, b) -> a
fst (([ShowS], Game x y) -> [ShowS])
-> ([Turn x y] -> ([ShowS], Game x y)) -> [Turn x y] -> [ShowS]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Turn x y -> ([ShowS], Game x y) -> ([ShowS], Game x y))
-> ([ShowS], Game x y) -> [Turn x y] -> ([ShowS], Game x y)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (
\Turn x y
turn ([ShowS]
l, Game x y
game') -> (
Bool -> Turn x y -> Game x y -> ShowS
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Bool -> Turn x y -> Game x y -> ShowS
ContextualNotation.StandardAlgebraic.showsTurn Bool
False Turn x y
turn Game x y
game' ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [ShowS]
l,
Turn x y -> Transformation x y
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Turn x y -> Transformation x y
Model.Game.takeTurn Turn x y
turn Game x y
game'
)
) ([], Game x y
forall a. Default a => a
Data.Default.def ) ([Turn x y] -> [ShowS]) -> [Turn x y] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ Game x y -> [Turn x y]
forall x y. Game x y -> [Turn x y]
Model.Game.listTurns Game x y
game
) where
showsBlockComment :: String -> ShowS
showsBlockComment :: Tag -> ShowS
showsBlockComment = PGNComment -> ShowS
forall a. Show a => a -> ShowS
shows (PGNComment -> ShowS) -> (Tag -> PGNComment) -> Tag -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> PGNComment
ContextualNotation.PGNComment.BlockComment
showsGame :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> IO ShowS
{-# SPECIALISE showsGame :: Model.Game.Game T.X T.Y -> IO ShowS #-}
showsGame :: Game x y -> IO ShowS
showsGame Game x y
game = do
UTCTime
utcTime <- IO UTCTime
Data.Time.Clock.getCurrentTime
ShowS -> IO ShowS
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS -> IO ShowS) -> (PGN x y -> ShowS) -> PGN x y -> IO ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGN x y -> ShowS
forall a. Show a => a -> ShowS
shows (PGN x y -> IO ShowS) -> PGN x y -> IO ShowS
forall a b. (a -> b) -> a -> b
$ Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game x y
-> PGN x y
forall x y.
Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game x y
-> PGN x y
mkPGN Maybe Tag
forall a. Maybe a
Nothing Maybe Tag
forall a. Maybe a
Nothing (UTCTime -> Day
Data.Time.Clock.utctDay UTCTime
utcTime) Maybe Tag
forall a. Maybe a
Nothing Maybe Tag
forall a. Maybe a
Nothing Maybe Tag
forall a. Maybe a
Nothing [] Game x y
game
nagParser :: (
Num i,
Ord i,
Show i
) =>
#ifdef USE_POLYPARSE
Text.Poly.TextParser i
nagParser :: TextParser i
nagParser = do
i
code <- Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser () -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> TextParser ()
Text.Poly.char Char
nagPrefix TextParser () -> TextParser i -> TextParser i
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser i
forall i. Num i => TextParser i
Text.Poly.unsignedDecimal
if i
code i -> i -> Bool
forall a. Ord a => a -> a -> Bool
> i
maxCode
then Tag -> TextParser i
forall (p :: * -> *) a. PolyParse p => Tag -> p a
Poly.failBad (Tag -> TextParser i) -> ShowS -> Tag -> TextParser i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ShowS
forall a. Show a => a -> ShowS
shows i
code ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
" > maximum NAG" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation (Tag -> TextParser i) -> Tag -> TextParser i
forall a b. (a -> b) -> a -> b
$ i -> ShowS
forall a. Show a => a -> ShowS
shows i
maxCode Tag
"."
else i -> TextParser i
forall (m :: * -> *) a. Monad m => a -> m a
return i
code
#else /* Parsec */
Parsec.Parser i
nagParser = Parsec.try $ do
code <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.char nagPrefix >> fmap Data.Integral.stringToUnsignedDecimal (Control.Applicative.some Parsec.digit)
if code > maxCode
then fail . shows code . showString " > maximum NAG" . Text.ShowList.showsAssociation $ shows maxCode "."
else return code
#endif
where
maxCode :: i
maxCode = i
255
moveNumberParser :: Num n =>
#ifdef USE_POLYPARSE
Text.Poly.TextParser n
moveNumberParser :: TextParser n
moveNumberParser = Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser n -> TextParser n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser n
forall i. Num i => TextParser i
Text.Poly.unsignedDecimal TextParser n -> Parser Char [()] -> TextParser n
forall (p :: * -> *) a b. PolyParse p => p a -> p b -> p a
`Poly.discard` TextParser () -> Parser Char [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.some (Char -> TextParser ()
Text.Poly.char Char
moveNumberTerminator)
#else /* Parsec */
Parsec.Parser n
moveNumberParser = Parsec.try $ Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> fmap Data.Integral.stringToUnsignedDecimal (
Parsec.manyTill Parsec.digit (
Control.Applicative.some $ Parsec.char moveNumberTerminator
) <?> "Move-number"
)
#endif
maybeResultParser ::
#ifdef USE_POLYPARSE
Text.Poly.TextParser (Maybe Model.Result.Result)
maybeResultParser :: TextParser (Maybe Result)
maybeResultParser = Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser ()
-> TextParser (Maybe Result) -> TextParser (Maybe Result)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Tag, TextParser (Maybe Result))] -> TextParser (Maybe Result)
forall (p :: * -> *) a. Commitment p => [(Tag, p a)] -> p a
Poly.oneOf' [
(
Tag
"Result",
[TextParser (Maybe Result)] -> TextParser (Maybe Result)
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
Poly.oneOf ([TextParser (Maybe Result)] -> TextParser (Maybe Result))
-> [TextParser (Maybe Result)] -> TextParser (Maybe Result)
forall a b. (a -> b) -> a -> b
$ (Result -> TextParser (Maybe Result))
-> [Result] -> [TextParser (Maybe Result)]
forall a b. (a -> b) -> [a] -> [b]
map (
\Result
result -> Tag -> TextParser ()
Text.Poly.string (Result -> Tag
forall a. Show a => a -> Tag
show Result
result) TextParser ()
-> TextParser (Maybe Result) -> TextParser (Maybe Result)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Result -> TextParser (Maybe Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
result)
) [Result]
Model.Result.range
), (
Tag
"Game unfinished",
TextParser () -> TextParser ()
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (Char -> TextParser ()
Text.Poly.char Char
inProgressFlag) TextParser ()
-> TextParser (Maybe Result) -> TextParser (Maybe Result)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Result -> TextParser (Maybe Result)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Result
forall a. Maybe a
Nothing
)
]
#else /* Parsec */
Parsec.Parser (Maybe Model.Result.Result)
maybeResultParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> (
Parsec.try (
Parsec.choice $ map (
\result -> Parsec.try $ (Parsec.string (show result) <?> "Result") >> return (Just result)
) Model.Result.range
) <|> (
(Parsec.char inProgressFlag <?> "Game unfinished") >> return Nothing
)
)
#endif
moveTextParser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
#ifdef USE_POLYPARSE
=> IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> Text.Poly.TextParser (Model.Game.Game x y)
{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Text.Poly.TextParser (Model.Game.Game T.X T.Y) #-}
moveTextParser :: Bool -> Bool -> TextParser (Game x y)
moveTextParser Bool
isStrictlySequential Bool
validateMoves = let
elementSequenceParser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> Text.Poly.TextParser (Model.Game.Game x y)
elementSequenceParser :: Game x y -> TextParser (Game x y)
elementSequenceParser Game x y
game = let
expectedMoveNumber :: Int
expectedMoveNumber = Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int)
-> (TurnsByLogicalColour (Turn x y) -> Int)
-> TurnsByLogicalColour (Turn x y)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Int -> Int)
-> (TurnsByLogicalColour (Turn x y) -> Int)
-> TurnsByLogicalColour (Turn x y)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TurnsByLogicalColour (Turn x y) -> Int
forall turn. TurnsByLogicalColour turn -> Int
State.TurnsByLogicalColour.getNPlies (TurnsByLogicalColour (Turn x y) -> Int)
-> TurnsByLogicalColour (Turn x y) -> Int
forall a b. (a -> b) -> a -> b
$ Game x y -> TurnsByLogicalColour (Turn x y)
forall x y. Game x y -> TurnsByLogicalColour x y
Model.Game.getTurnsByLogicalColour Game x y
game
in do
Int
moveNumber <- (
if LogicalColour -> Bool
Attribute.LogicalColour.isBlack (LogicalColour -> Bool) -> LogicalColour -> Bool
forall a b. (a -> b) -> a -> b
$ Game x y -> LogicalColour
forall x y. Game x y -> LogicalColour
Model.Game.getNextLogicalColour Game x y
game
then (Maybe Int -> Int) -> Parser Char (Maybe Int) -> Parser Char Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Int
expectedMoveNumber) (Parser Char (Maybe Int) -> Parser Char Int)
-> (Parser Char Int -> Parser Char (Maybe Int))
-> Parser Char Int
-> Parser Char Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Char Int -> Parser Char (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional
else Parser Char Int -> Parser Char Int
forall a. a -> a
id
) Parser Char Int
forall i. Num i => TextParser i
moveNumberParser
if Bool
isStrictlySequential Bool -> Bool -> Bool
&& Int
moveNumber Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expectedMoveNumber
then do
Tag
context <- Parser Char Char -> TextParser () -> Parser Char Tag
forall (p :: * -> *) a z.
(PolyParse p, Show a) =>
p a -> p z -> p [a]
Poly.manyFinally' Parser Char Char
forall t. Parser t t
Poly.next (TextParser () -> Parser Char Tag)
-> TextParser () -> Parser Char Tag
forall a b. (a -> b) -> a -> b
$ Char -> TextParser ()
Text.Poly.char Char
'\n'
Tag -> TextParser (Game x y)
forall (p :: * -> *) a. PolyParse p => Tag -> p a
Poly.failBad (Tag -> TextParser (Game x y))
-> ShowS -> Tag -> TextParser (Game x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
"found " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogicalColour -> ShowS
forall a. Show a => a -> ShowS
shows (Game x y -> LogicalColour
forall x y. Game x y -> LogicalColour
Model.Game.getNextLogicalColour Game x y
game) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
" move-number" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
moveNumber ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
" where " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
expectedMoveNumber ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> ShowS
showString Tag
" expected, before " (Tag -> TextParser (Game x y)) -> Tag -> TextParser (Game x y)
forall a b. (a -> b) -> a -> b
$ Tag -> ShowS
forall a. Show a => a -> ShowS
shows Tag
context Tag
"."
else do
Game x y
game' <- (StandardAlgebraic x y -> Game x y)
-> Parser Char (StandardAlgebraic x y) -> TextParser (Game x y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StandardAlgebraic x y -> Transformation x y
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
StandardAlgebraic x y -> Transformation x y
`ContextualNotation.StandardAlgebraic.movePiece` Game x y
game) (Parser Char (StandardAlgebraic x y) -> TextParser (Game x y))
-> Parser Char (StandardAlgebraic x y) -> TextParser (Game x y)
forall a b. (a -> b) -> a -> b
$ Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment]
-> Parser Char (StandardAlgebraic x y)
-> Parser Char (StandardAlgebraic x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Bool -> Game x y -> Parser Char (StandardAlgebraic x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Bool -> Bool -> Game x y -> TextParser (StandardAlgebraic x y)
ContextualNotation.StandardAlgebraic.parser Bool
False Bool
validateMoves Game x y
game
Parser Char Int -> Parser Char [Int]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many (
Parser Char Int
forall i. (Num i, Ord i, Show i) => TextParser i
nagParser :: Text.Poly.TextParser Int
) Parser Char [Int]
-> Parser Char [Game x y] -> Parser Char [Game x y]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser (Game x y) -> Parser Char [Game x y]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many (
(TextParser ()
-> TextParser () -> TextParser (Game x y) -> TextParser (Game x y))
-> (TextParser (), TextParser ())
-> TextParser (Game x y)
-> TextParser (Game x y)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TextParser ()
-> TextParser () -> TextParser (Game x y) -> TextParser (Game x y)
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
Poly.bracket (
(
\Char
c -> Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser () -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> TextParser ()
Text.Poly.char Char
c
) (Char -> TextParser ())
-> (Char -> TextParser ())
-> (Char, Char)
-> (TextParser (), TextParser ())
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (
\Char
c -> TextParser () -> TextParser ()
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (TextParser () -> TextParser ()) -> TextParser () -> TextParser ()
forall a b. (a -> b) -> a -> b
$ Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser () -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> TextParser ()
Text.Poly.char Char
c
) ((Char, Char) -> (TextParser (), TextParser ()))
-> (Char, Char) -> (TextParser (), TextParser ())
forall a b. (a -> b) -> a -> b
$ (Char, Char)
ravDelimiters
) (TextParser (Game x y) -> TextParser (Game x y))
-> TextParser (Game x y) -> TextParser (Game x y)
forall a b. (a -> b) -> a -> b
$ Game x y -> TextParser (Game x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Game x y -> TextParser (Game x y)
elementSequenceParser Game x y
game
) Parser Char [Game x y]
-> TextParser (Game x y) -> TextParser (Game x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Maybe (Game x y) -> Game x y)
-> Parser Char (Maybe (Game x y)) -> TextParser (Game x y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Game x y -> Maybe (Game x y) -> Game x y
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Game x y
game') (
TextParser (Game x y) -> Parser Char (Maybe (Game x y))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional (TextParser (Game x y) -> Parser Char (Maybe (Game x y)))
-> TextParser (Game x y) -> Parser Char (Maybe (Game x y))
forall a b. (a -> b) -> a -> b
$ Game x y -> TextParser (Game x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Game x y -> TextParser (Game x y)
elementSequenceParser Game x y
game'
)
in do
Game x y
game <- (Maybe (Game x y) -> Game x y)
-> Parser Char (Maybe (Game x y)) -> TextParser (Game x y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Game x y -> Maybe (Game x y) -> Game x y
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Game x y
forall a. Default a => a
Data.Default.def ) (Parser Char (Maybe (Game x y)) -> TextParser (Game x y))
-> (TextParser (Game x y) -> Parser Char (Maybe (Game x y)))
-> TextParser (Game x y)
-> TextParser (Game x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextParser (Game x y) -> Parser Char (Maybe (Game x y))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional (TextParser (Game x y) -> TextParser (Game x y))
-> TextParser (Game x y) -> TextParser (Game x y)
forall a b. (a -> b) -> a -> b
$ Game x y -> TextParser (Game x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Game x y -> TextParser (Game x y)
elementSequenceParser Game x y
forall a. Default a => a
Data.Default.def
#else /* Parsec */
=> IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> Parsec.Parser (Model.Game.Game x y)
{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Parsec.Parser (Model.Game.Game T.X T.Y) #-}
moveTextParser isStrictlySequential validateMoves = let
elementSequenceParser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> Parsec.Parser (Model.Game.Game x y)
elementSequenceParser game = let
expectedMoveNumber = succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game
in do
moveNumber <- (
if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game
then fmap (Data.Maybe.fromMaybe expectedMoveNumber) . Control.Applicative.optional
else id
) moveNumberParser
if isStrictlySequential && moveNumber /= expectedMoveNumber
then fail . showString "found " . shows (Model.Game.getNextLogicalColour game) . showString " move-number" . Text.ShowList.showsAssociation . shows moveNumber . showString " where " $ shows expectedMoveNumber " expected."
else do
game' <- (`ContextualNotation.StandardAlgebraic.movePiece` game) <$> (Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> ContextualNotation.StandardAlgebraic.parser False validateMoves game)
Control.Applicative.many (
nagParser :: Parsec.Parser Int
) >> Control.Applicative.many (
Parsec.try . uncurry Parsec.between (
(
\c -> Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.char c
) *** (
\c -> Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.char c
) $ ravDelimiters
) $ elementSequenceParser game
) >> Parsec.option game' (
Parsec.try $ elementSequenceParser game'
)
in do
game <- Parsec.option Data.Default.def . Parsec.try $ elementSequenceParser Data.Default.def
#endif
Game x y -> (Result -> Game x y) -> Maybe Result -> Game x y
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe Game x y
game (Result -> Transformation x y
forall x y. Result -> Transformation x y
`Model.Game.updateTerminationReasonWith` Game x y
game) (Maybe Result -> Game x y)
-> TextParser (Maybe Result) -> TextParser (Game x y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser (Maybe Result)
maybeResultParser
parser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> [Tag]
#ifdef USE_POLYPARSE
-> Text.Poly.TextParser (PGN x y)
{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Text.Poly.TextParser (PGN T.X T.Y) #-}
parser :: Bool -> Bool -> [Tag] -> TextParser (PGN x y)
parser Bool
isStrictlySequential Bool
validateMoves [Tag]
identificationTags = do
[TagPair]
tagPairs <- Parser Char TagPair -> Parser Char [TagPair]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many (Parser Char TagPair -> Parser Char [TagPair])
-> Parser Char TagPair -> Parser Char [TagPair]
forall a b. (a -> b) -> a -> b
$ Parser Char TagPair
tagPairParser Parser Char TagPair -> Parser Char [Tag] -> Parser Char TagPair
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char Tag -> Parser Char [Tag]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char Tag
ContextualNotation.PGNComment.parser
Game x y
moveText <- TextParser (Game x y)
moveTextParser' TextParser (Game x y) -> Parser Char [Tag] -> TextParser (Game x y)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char Tag -> Parser Char [Tag]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char Tag
ContextualNotation.PGNComment.parser
PGN x y -> TextParser (PGN x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (PGN x y -> TextParser (PGN x y))
-> PGN x y -> TextParser (PGN x y)
forall a b. (a -> b) -> a -> b
$ [Tag] -> [TagPair] -> Game x y -> PGN x y
forall x y. [Tag] -> [TagPair] -> Game x y -> PGN x y
mkPGN' [Tag]
identificationTags ([TagPair] -> [TagPair]
removeUnknownTagValues [TagPair]
tagPairs) Game x y
moveText
where
tagPairParser :: Text.Poly.TextParser TagPair
tagPairParser :: Parser Char TagPair
tagPairParser = Parser Char Tag -> Parser Char [Tag]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char Tag
ContextualNotation.PGNComment.parser Parser Char [Tag] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser () -> Parser Char TagPair -> Parser Char TagPair
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (TextParser ()
-> TextParser () -> Parser Char TagPair -> Parser Char TagPair)
-> (TextParser (), TextParser ())
-> Parser Char TagPair
-> Parser Char TagPair
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TextParser ()
-> TextParser () -> Parser Char TagPair -> Parser Char TagPair
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
Poly.bracket (
Char -> TextParser ()
Text.Poly.char (Char -> TextParser ())
-> (Char -> TextParser ())
-> (Char, Char)
-> (TextParser (), TextParser ())
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** TextParser () -> TextParser ()
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (TextParser () -> TextParser ())
-> (Char -> TextParser ()) -> Char -> TextParser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> TextParser ()
Text.Poly.char ((Char, Char) -> (TextParser (), TextParser ()))
-> (Char, Char) -> (TextParser (), TextParser ())
forall a b. (a -> b) -> a -> b
$ (Char, Char)
tagPairDelimiters
) (
do
Tag
tagName <- Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser () -> Parser Char Tag -> Parser Char Tag
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char Tag -> Parser Char Tag
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (Parser Char Char -> Parser Char Tag
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.some (Parser Char Char -> Parser Char Tag)
-> Parser Char Char -> Parser Char Tag
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Tag -> Parser Char Char
forall t. Show t => (t -> Bool) -> Tag -> Parser t t
Poly.satisfyMsg Char -> Bool
isValidTagCharacter Tag
"Tag-name")
Tag
tagValue <- Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces TextParser () -> Parser Char Tag -> Parser Char Tag
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
-> TextParser () -> Parser Char Tag -> Parser Char Tag
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
Poly.bracket (
Char -> TextParser ()
Text.Poly.char Char
quoteDelimiter
) (
TextParser () -> TextParser ()
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (TextParser () -> TextParser ()) -> TextParser () -> TextParser ()
forall a b. (a -> b) -> a -> b
$ Char -> TextParser ()
Text.Poly.char Char
quoteDelimiter
) (
Parser Char Char -> Parser Char Tag
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many (Parser Char Char -> Parser Char Tag)
-> Parser Char Char -> Parser Char Tag
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Tag -> Parser Char Char
forall t. Show t => (t -> Bool) -> Tag -> Parser t t
Poly.satisfyMsg (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
quoteDelimiter) Tag
"Tag-value"
)
Parser Char PGNComment -> Parser Char [PGNComment]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many Parser Char PGNComment
ContextualNotation.PGNComment.blockCommentParser Parser Char [PGNComment] -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
Text.Poly.spaces
TagPair -> Parser Char TagPair
forall (m :: * -> *) a. Monad m => a -> m a
return (Tag
tagName, Tag
tagValue)
)
#else /* Parsec */
-> Parsec.Parser (PGN x y)
{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Parsec.Parser (PGN T.X T.Y) #-}
parser isStrictlySequential validateMoves identificationTags = mkPGN' identificationTags <$> (
removeUnknownTagValues <$> Control.Applicative.many (
tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser
)
) <*> moveTextParser' <* Control.Applicative.many ContextualNotation.PGNComment.parser
where
tagPairParser :: Parsec.Parser TagPair
tagPairParser = Parsec.try $ Control.Applicative.many ContextualNotation.PGNComment.parser >> Parsec.spaces >> uncurry Parsec.between (
Parsec.char *** Parsec.char $ tagPairDelimiters
) (
do
tagName <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> (Control.Applicative.some (Parsec.satisfy isValidTagCharacter) <?> "Tag-name")
tagValue <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.between (
Parsec.char quoteDelimiter
) (
Parsec.char quoteDelimiter
) (
Control.Applicative.many (Parsec.satisfy (/= quoteDelimiter)) <?> "Tag-value"
)
Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces
return (tagName, tagValue)
)
#endif
moveTextParser' :: TextParser (Game x y)
moveTextParser' = Bool -> Bool -> TextParser (Game x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Bool -> Bool -> TextParser (Game x y)
moveTextParser Bool
isStrictlySequential Bool
validateMoves
isValidTagCharacter :: Char -> Bool
isValidTagCharacter :: Char -> Bool
isValidTagCharacter = (Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(&&) ((Bool, Bool) -> Bool) -> (Char -> (Bool, Bool)) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Data.Char.isSpace (Char -> Bool) -> (Char -> Bool) -> Char -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
quoteDelimiter))
removeUnknownTagValues :: [TagPair] -> [TagPair]
removeUnknownTagValues :: [TagPair] -> [TagPair]
removeUnknownTagValues = (TagPair -> Bool) -> [TagPair] -> [TagPair]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char
unknownTagValue]) (Tag -> Bool) -> (TagPair -> Tag) -> TagPair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagPair -> Tag
forall a b. (a, b) -> b
snd )