{-# LANGUAGE CPP #-}
{-
	Copyright (C) 2018 Dr. Alistair Ward

	This file is part of BishBosh.

	BishBosh is free software: you can redistribute it and/or modify
	it under the terms of the GNU General Public License as published by
	the Free Software Foundation, either version 3 of the License, or
	(at your option) any later version.

	BishBosh is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	GNU General Public License for more details.

	You should have received a copy of the GNU General Public License
	along with BishBosh.  If not, see <http://www.gnu.org/licenses/>.
-}
{- |
 [@AUTHOR@]	Dr. Alistair Ward

 [@DESCRIPTION@]	Defines a parser for PGN; <https://www.chessclub.com/help/pgn-spec>.
-}

module BishBosh.ContextualNotation.PGN(
-- * Types
-- ** Type-synonyms
	Tag,
--	Value,
--	TagPair,
	IsStrictlySequential,
-- ** Data-types
	PGN(
--		MkPGN,
--		getMaybeEventName,
--		getMaybeSiteName,
--		getDay,
		getMaybeRoundName,
--		getMaybeWhitePlayerName,
--		getMaybeBlackPlayerName,
		getIdentificationTagPairs,
		getGame
	),
-- * Constants
--	tagPairDelimiters,
--	ravDelimiters,
--	inProgressFlag,
--	moveNumberTerminator,
	quoteDelimiter,
--	dateComponentSeparator,
	unknownTagValue,
--	eventNameTag,
--	siteNameTag,
	dateTag,
--	roundNameTag,
--	whitePlayerNameTag,
--	blackPlayerNameTag,
--	resultTag,
-- * Functions
	showsDate,
	showsMoveText,
	showsGame,
--	nagParser,
--	moveNumberParser,
--	maybeResultParser,
	moveTextParser,
	parser,
-- ** Constructors
	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

-- | The constant delimiters for a /tag-pair/.
tagPairDelimiters :: (Char, Char)
tagPairDelimiters :: (Char, Char)
tagPairDelimiters	= (Char
'[', Char
']')

-- | The constant delimiters for a /Recursive Annotation Variation/.
ravDelimiters :: (Char, Char)
ravDelimiters :: (Char, Char)
ravDelimiters		= (Char
'(', Char
')')

-- | Constant indication of a game still in progress.
inProgressFlag :: Char
inProgressFlag :: Char
inProgressFlag		= Char
'*'

-- | Constant prefix for a /Numeric Annotation Glyph/.
nagPrefix :: Char
nagPrefix :: Char
nagPrefix		= Char
'$'

-- | Constant terminator for a move-number.
moveNumberTerminator :: Char
moveNumberTerminator :: Char
moveNumberTerminator	= Char
'.'

-- | Constant delimiter for a tag-value.
quoteDelimiter :: Char
quoteDelimiter :: Char
quoteDelimiter		= Char
'"'

-- | Constant separator between the components of a date.
dateComponentSeparator :: Char
dateComponentSeparator :: Char
dateComponentSeparator	= Char
'.'

-- | Constant used to represent an unknown value for a mandatory tag.
unknownTagValue :: Char
unknownTagValue :: Char
unknownTagValue		= Char
'?'

-- | The type of the name of field in a PGN-specification.
type Tag	= String

-- | The type of the value of field in a PGN-specification.
type Value	= String

-- | Self-documentation.
type TagPair	= (Tag, Value)

-- | Whether moves with an unexpected move-number should be considered to be an error.
type IsStrictlySequential	= Bool

-- | Qualifies a mandatory tag-value.
eventNameTag :: Tag
eventNameTag :: Tag
eventNameTag		= Tag
"Event"

-- | Qualifies a mandatory tag-value.
siteNameTag :: Tag
siteNameTag :: Tag
siteNameTag		= Tag
"Site"

-- | Qualifies a mandatory tag-value.
dateTag :: Tag
dateTag :: Tag
dateTag			= Tag
"Date"

-- | Qualifies a tag-value.
roundNameTag :: Tag
roundNameTag :: Tag
roundNameTag		= Tag
"Round"

-- | Qualifies a mandatory tag-value.
whitePlayerNameTag :: Tag
whitePlayerNameTag :: Tag
whitePlayerNameTag	= Tag
"White"

-- | Qualifies a mandatory tag-value.
blackPlayerNameTag :: Tag
blackPlayerNameTag :: Tag
blackPlayerNameTag	= Tag
"Black"

-- | Qualifies a tag-value.
resultTag :: Tag
resultTag :: Tag
resultTag		= Tag
"Result"

-- | Shows the specified date in double quotes.
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

{- |
	* The data defined by PGN.

	* The first six fields are mandatory according to the PGN-specification, though none are used by this application.
	The seventh mandatory field /Result/ can be derived from 'getGame'.
-}
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,		-- ^ The name of the round; typically dotted decimal.
	PGN -> Maybe Tag
getMaybeWhitePlayerName		:: Maybe Value,
	PGN -> Maybe Tag
getMaybeBlackPlayerName		:: Maybe Value,
	PGN -> [TagPair]
getIdentificationTagPairs	:: [TagPair],		-- ^ Arbitrary tagged values.
	PGN -> Game
getGame				:: Model.Game.Game	-- ^ Defines the turn-sequence & the result.
} 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)	-- CAVEAT: treat other fields lazily, since though they're specified as mandatory, this is isn't observed in practice because they're not typically required.

-- | Smart constructor.
mkPGN
	:: Maybe Value	-- ^ Event-name.
	-> Maybe Value	-- ^ Site-name.
	-> Data.Time.Calendar.Day
	-> Maybe Value	-- ^ Round.
	-> Maybe Value	-- ^ Name of White player.
	-> Maybe Value	-- ^ Name of Black player.
	-> [TagPair]	-- ^ Arbitrary tag-pairs.
	-> 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 {-tag-value-}
	) [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
					)
				 ] -- Those tags for which an unknown value is represented by 'unknownTagValue'.
		 ] -- List-comprehension.

-- | Smart constructor.
mkPGN'
	:: [Tag]	-- ^ Identify fields used to form a unique composite game-identifier.
	-> [TagPair]	-- ^ The data from which to extract the required values.
	-> 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 {-to Parser-monad-} (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	-- N.B.: this will only terminate the application when the date is evaluated.
	) (
#	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 {-to ParsecT-monad-} $ 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	-- N.B.: this will only terminate the application when the date is evaluated.
	) (
		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 {-tag-}
 ) [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
	 ]

{- |
	* Represents the specified /game/ in /Portable Game Notation/; <https://www.chessclub.com/help/pgn-spec>.

	* This function is only responsible for the line defining the numbered sequence of /move/s represented in SAN.
-}
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
' '	-- Show an element.
			) ([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 {-chronological-} ([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'
		) -- Pair.
	) ([], Game
forall a. Default a => a
Data.Default.def {-game-}) ([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

-- | Shows PGN for the specified /game/, with defaults for other fields.
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 {-to IO-monad-} (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

-- | Parse a /Numeric Annotation Glyph/.
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 {-to Parser-monad-} 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 {-to ParsecT-monad-} code
#endif
	where
		maxCode :: i
maxCode	= i
255

{- |
	* Parses a move-number.

	* N.B.: officially terminated by a single period (for White), or three (by Black); though this parser is more flexible.
-}
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

-- | Parse an optional result.
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 {-to Parser-monad-} (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
result)	-- CAVEAT: for some reason, this conflates "1-0" with "1/2-1/2", when lazy-parsing with ghc-8.0.1 & polyparse-1.12 ?!
		) [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 {-to Parser-monad-} 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 {-to ParsecT-monad-} (Just result)
		) Property.FixedMembership.members
	) <|> (
		(Parsec.char inProgressFlag <?> "Game unfinished") >> return {-to ParsecT-monad-} Nothing
	)
 )
#endif

-- | Parses a /game/ from PGN move-text.
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 {-explicitEnPassant-} 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 {-recurse-}
				 ) 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' {-recurse-}
				 )
 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 {-game-}) (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 {-game-}
#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 {-explicitEnPassant-} 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 {-recurse-}
				 ) >> Parsec.option game' (
					Parsec.try $ elementSequenceParser game' {-recurse-}
				 )
 in do
	game	<- Parsec.option Data.Default.def {-game-} . Parsec.try $ elementSequenceParser Data.Default.def {-game-}
#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

{- |
	* Parses /PGN/.

	* CAVEAT: this function doesn't /produce/ when using either "Parsec" or "Poly.Plain", since it returns 'Either' the appropriate constructor for which may be unknown until the last character is parsed.
	Equally for these parsers, all data must be strictly evaluated before any data can retrieved.
-}
parser
	:: IsStrictlySequential
	-> ContextualNotation.StandardAlgebraic.ValidateMoves
	-> [Tag]	-- ^ Identify fields used to form a unique composite game-identifier.
#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 {-to Parser-monad-} (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"	-- TODO: must account for escaped quotes.
				 )

				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 {-to Parser-monad-} (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"	-- TODO: must account for escaped quotes.
				 )

				Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces

				return {-to ParsecT-monad-} (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 {-tag-value-})