{-# LANGUAGE CPP #-}
module BishBosh.ContextualNotation.PGN(
Tag,
IsStrictlySequential,
PGN(
getMaybeRoundName,
getIdentificationTagPairs,
getGame
),
quoteDelimiter,
unknownTagValue,
dateTag,
showsDate,
showsMoveText,
showsGame,
moveTextParser,
parser,
mkPGN,
mkPGN'
) where
import Control.Arrow((&&&), (***))
import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour
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.Property.FixedMembership as Property.FixedMembership
import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason
import qualified BishBosh.Rule.Result as Rule.Result
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Type.Count as Type.Count
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 as 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 == 'L'
import qualified Text.ParserCombinators.Poly.Lazy as Poly
# elif USE_POLYPARSE == 'P'
import qualified Text.ParserCombinators.Poly.Plain as Poly
# else
# error "USE_POLYPARSE invalid"
# 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 = MkPGN {
PGN -> Maybe Tag
getMaybeEventName :: Maybe Value,
PGN -> Maybe Tag
getMaybeSiteName :: Maybe Value,
PGN -> Day
getDay :: Data.Time.Calendar.Day,
PGN -> Maybe Tag
getMaybeRoundName :: Maybe Value,
PGN -> Maybe Tag
getMaybeWhitePlayerName :: Maybe Value,
PGN -> Maybe Tag
getMaybeBlackPlayerName :: Maybe Value,
PGN -> [TagPair]
getIdentificationTagPairs :: [TagPair],
PGN -> Game
getGame :: Model.Game.Game
} deriving PGN -> PGN -> Bool
(PGN -> PGN -> Bool) -> (PGN -> PGN -> Bool) -> Eq PGN
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGN -> PGN -> Bool
$c/= :: PGN -> PGN -> Bool
== :: PGN -> PGN -> Bool
$c== :: PGN -> PGN -> Bool
Eq
instance Show PGN where
showsPrec :: Int -> PGN -> ShowS
showsPrec Int
_ MkPGN {
getMaybeEventName :: PGN -> Maybe Tag
getMaybeEventName = Maybe Tag
maybeEventName,
getMaybeSiteName :: PGN -> Maybe Tag
getMaybeSiteName = Maybe Tag
maybeSiteName,
getDay :: PGN -> Day
getDay = Day
day,
getMaybeRoundName :: PGN -> Maybe Tag
getMaybeRoundName = Maybe Tag
maybeRoundName,
getMaybeWhitePlayerName :: PGN -> Maybe Tag
getMaybeWhitePlayerName = Maybe Tag
maybeWhitePlayerName,
getMaybeBlackPlayerName :: PGN -> Maybe Tag
getMaybeBlackPlayerName = Maybe Tag
maybeBlackPlayerName,
getIdentificationTagPairs :: PGN -> [TagPair]
getIdentificationTagPairs = [TagPair]
identificationTagPairs,
getGame :: PGN -> Game
getGame = Game
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 -> ShowS
showsMoveText Game
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
Rule.GameTerminationReason.toResult) (Maybe GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason -> ShowS
forall a b. (a -> b) -> a -> b
$ Game -> Maybe GameTerminationReason
Model.Game.getMaybeTerminationReason Game
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 PGN where
rnf :: PGN -> ()
rnf MkPGN {
getIdentificationTagPairs :: PGN -> [TagPair]
getIdentificationTagPairs = [TagPair]
identificationTagPairs,
getGame :: PGN -> Game
getGame = Game
game
} = ([TagPair], Game) -> ()
forall a. NFData a => a -> ()
Control.DeepSeq.rnf ([TagPair]
identificationTagPairs, Game
game)
mkPGN
:: Maybe Value
-> Maybe Value
-> Data.Time.Calendar.Day
-> Maybe Value
-> Maybe Value
-> Maybe Value
-> [TagPair]
-> Model.Game.Game
-> PGN
mkPGN :: Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game
-> PGN
mkPGN Maybe Tag
maybeEventName Maybe Tag
maybeSiteName Day
day Maybe Tag
maybeRoundName Maybe Tag
maybeWhitePlayerName Maybe Tag
maybeBlackPlayerName [TagPair]
identificationTagPairs Game
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
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> PGN) -> (Tag -> Exception) -> Tag -> PGN
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) -> Tag -> PGN
forall a b. (a -> b) -> a -> b
$ [TagPair] -> Tag
forall a. Show a => a -> Tag
show [TagPair]
explicitTags
| Bool
otherwise = MkPGN :: Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game
-> PGN
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
getGame = Game
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
)
]
]
mkPGN'
:: [Tag]
-> [TagPair]
-> Model.Game.Game
-> PGN
mkPGN' :: [Tag] -> [TagPair] -> Game -> PGN
mkPGN' [Tag]
identificationTags [TagPair]
tagPairs = Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game
-> PGN
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 != 'L'
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 -> PGN) -> [TagPair] -> Game -> PGN
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
`Map.lookup` [TagPair] -> Map Tag Tag
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [TagPair]
tagPairs
) [
Tag
eventNameTag,
Tag
siteNameTag,
Tag
dateTag,
Tag
roundNameTag,
Tag
whitePlayerNameTag,
Tag
blackPlayerNameTag
]
showsMoveText :: Model.Game.Game -> ShowS
showsMoveText :: Game -> ShowS
showsMoveText Game
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
Rule.GameTerminationReason.toResult
)
) (Maybe GameTerminationReason -> ShowS)
-> Maybe GameTerminationReason -> ShowS
forall a b. (a -> b) -> a -> b
$ Game -> Maybe GameTerminationReason
Model.Game.getMaybeTerminationReason Game
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 :: Type.Count.NMoves,
[ShowS] -> [ShowS]
forall a. [a] -> [a]
reverse ([ShowS] -> [ShowS]) -> [ShowS] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ ([ShowS], Game) -> [ShowS]
forall a b. (a, b) -> a
fst (([ShowS], Game) -> [ShowS])
-> ([Turn] -> ([ShowS], Game)) -> [Turn] -> [ShowS]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Turn -> ([ShowS], Game) -> ([ShowS], Game))
-> ([ShowS], Game) -> [Turn] -> ([ShowS], Game)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (
\Turn
turn ([ShowS]
l, Game
game') -> (
Bool -> Turn -> Game -> ShowS
ContextualNotation.StandardAlgebraic.showsTurn Bool
False Turn
turn Game
game' ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [ShowS]
l,
Turn -> Transformation
Model.Game.takeTurn Turn
turn Game
game'
)
) ([], Game
forall a. Default a => a
Data.Default.def ) ([Turn] -> [ShowS]) -> [Turn] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ Game -> [Turn]
Model.Game.listTurns Game
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 :: Model.Game.Game -> IO ShowS
showsGame :: Game -> IO ShowS
showsGame Game
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 -> ShowS) -> PGN -> IO ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGN -> ShowS
forall a. Show a => a -> ShowS
shows (PGN -> IO ShowS) -> PGN -> IO ShowS
forall a b. (a -> b) -> a -> b
$ Maybe Tag
-> Maybe Tag
-> Day
-> Maybe Tag
-> Maybe Tag
-> Maybe Tag
-> [TagPair]
-> Game
-> PGN
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
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 ::
#ifdef USE_POLYPARSE
Text.Poly.TextParser Type.Count.NMoves
moveNumberParser :: Parser Char Int
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] -> Parser Char Int -> Parser Char Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char Int
forall i. Num i => TextParser i
Text.Poly.unsignedDecimal Parser Char Int -> Parser Char [()] -> Parser Char Int
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 Type.Count.NMoves
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 Rule.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]
forall a. FixedMembership a => [a]
Property.FixedMembership.members
), (
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 Rule.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)
) Property.FixedMembership.members
) <|> (
(Parsec.char inProgressFlag <?> "Game unfinished") >> return Nothing
)
)
#endif
moveTextParser
:: IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
#ifdef USE_POLYPARSE
-> Text.Poly.TextParser Model.Game.Game
moveTextParser :: Bool -> Bool -> TextParser Game
moveTextParser Bool
isStrictlySequential Bool
validateMoves = let
elementSequenceParser :: Model.Game.Game -> Text.Poly.TextParser Model.Game.Game
elementSequenceParser :: Game -> TextParser Game
elementSequenceParser Game
game = let
expectedMoveNumber :: Type.Count.NMoves
expectedMoveNumber :: Int
expectedMoveNumber = TurnsByLogicalColour Turn -> Int
forall turn. TurnsByLogicalColour turn -> Int
State.TurnsByLogicalColour.deriveMoveNumber (TurnsByLogicalColour Turn -> Int)
-> TurnsByLogicalColour Turn -> Int
forall a b. (a -> b) -> a -> b
$ Game -> TurnsByLogicalColour Turn
Model.Game.getTurnsByLogicalColour Game
game
in do
Int
moveNumber <- (
if LogicalColour -> Bool
Colour.LogicalColour.isBlack (LogicalColour -> Bool) -> LogicalColour -> Bool
forall a b. (a -> b) -> a -> b
$ Game -> LogicalColour
Model.Game.getNextLogicalColour Game
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
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
forall (p :: * -> *) a. PolyParse p => Tag -> p a
Poly.failBad (Tag -> TextParser Game) -> ShowS -> Tag -> TextParser Game
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 -> LogicalColour
Model.Game.getNextLogicalColour Game
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) -> Tag -> TextParser Game
forall a b. (a -> b) -> a -> b
$ Tag -> ShowS
forall a. Show a => a -> ShowS
shows Tag
context Tag
"."
else do
Game
game' <- (StandardAlgebraic -> Game)
-> Parser Char StandardAlgebraic -> TextParser Game
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StandardAlgebraic -> Transformation
`ContextualNotation.StandardAlgebraic.movePiece` Game
game) (Parser Char StandardAlgebraic -> TextParser Game)
-> Parser Char StandardAlgebraic -> TextParser Game
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 -> Parser Char StandardAlgebraic
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Bool -> Game -> Parser Char StandardAlgebraic
ContextualNotation.StandardAlgebraic.parser Bool
False Bool
validateMoves Game
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] -> Parser Char [Game]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser Game -> Parser Char [Game]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.many (
(TextParser ()
-> TextParser () -> TextParser Game -> TextParser Game)
-> (TextParser (), TextParser ())
-> TextParser Game
-> TextParser Game
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TextParser ()
-> TextParser () -> TextParser Game -> TextParser Game
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 -> TextParser Game)
-> TextParser Game -> TextParser Game
forall a b. (a -> b) -> a -> b
$ Game -> TextParser Game
elementSequenceParser Game
game
) Parser Char [Game] -> TextParser Game -> TextParser Game
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Maybe Game -> Game) -> Parser Char (Maybe Game) -> TextParser Game
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Game -> Maybe Game -> Game
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Game
game') (
TextParser Game -> Parser Char (Maybe Game)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional (TextParser Game -> Parser Char (Maybe Game))
-> TextParser Game -> Parser Char (Maybe Game)
forall a b. (a -> b) -> a -> b
$ Game -> TextParser Game
elementSequenceParser Game
game'
)
in do
Game
game <- (Maybe Game -> Game) -> Parser Char (Maybe Game) -> TextParser Game
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Game -> Maybe Game -> Game
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Game
forall a. Default a => a
Data.Default.def ) (Parser Char (Maybe Game) -> TextParser Game)
-> (TextParser Game -> Parser Char (Maybe Game))
-> TextParser Game
-> TextParser Game
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextParser Game -> Parser Char (Maybe Game)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional (TextParser Game -> TextParser Game)
-> TextParser Game -> TextParser Game
forall a b. (a -> b) -> a -> b
$ Game -> TextParser Game
elementSequenceParser Game
forall a. Default a => a
Data.Default.def
#else /* Parsec */
-> Parsec.Parser Model.Game.Game
moveTextParser isStrictlySequential validateMoves = let
elementSequenceParser :: Model.Game.Game -> Parsec.Parser Model.Game.Game
elementSequenceParser game = let
expectedMoveNumber :: Type.Count.NMoves
expectedMoveNumber = State.TurnsByLogicalColour.deriveMoveNumber $ Model.Game.getTurnsByLogicalColour game
in do
moveNumber <- (
if Colour.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 -> (Result -> Game) -> Maybe Result -> Game
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe Game
game (Result -> Transformation
`Model.Game.updateTerminationReasonWith` Game
game) (Maybe Result -> Game)
-> TextParser (Maybe Result) -> TextParser Game
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser (Maybe Result)
maybeResultParser
parser
:: IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> [Tag]
#ifdef USE_POLYPARSE
-> Text.Poly.TextParser PGN
parser :: Bool -> Bool -> [Tag] -> TextParser PGN
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
game <- TextParser Game
moveTextParser' TextParser Game -> Parser Char [Tag] -> TextParser Game
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 -> TextParser PGN
forall (m :: * -> *) a. Monad m => a -> m a
return (PGN -> TextParser PGN) -> PGN -> TextParser PGN
forall a b. (a -> b) -> a -> b
$ [Tag] -> [TagPair] -> Game -> PGN
mkPGN' [Tag]
identificationTags ([TagPair] -> [TagPair]
removeUnknownTagValues [TagPair]
tagPairs) Game
game
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
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
moveTextParser' = Bool -> Bool -> TextParser Game
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 )