module PGN (
  PGN(..),
  pgnParser
) where 

import Control.Monad

import Data.Char
import Data.Maybe

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language (emptyDef)

import SAN

data PGN = PGN [PGNTag] [PGNMove]
  deriving (Eq, Show)

type PGNMove = SANFullMove

type PGNTag = (String,String)

lexer :: P.TokenParser ()
lexer = P.makeTokenParser emptyDef
  { P.commentStart = "{",
    P.commentEnd   = "}",
    P.commentLine  = ";" }

-- Bind the lexical parsers at top-level.
whiteSpace :: Parser ()
whiteSpace = P.whiteSpace lexer

decimal :: Parser Integer
decimal = P.decimal lexer

lexeme :: Parser a -> Parser a
lexeme = P.lexeme lexer

{-
-- Parser for a PGN symbol token.
pgnSymbol :: Parser String
pgnSymbol = lexeme $ do
  first <- alphaNum
  rest <- many (alphaNum <|> oneOf "_+#=:-")
  return (first:rest)
-}

-- Mandatory PGN tags (seven tag roster).
pgnSTR :: [String]
pgnSTR = ["Event", "Site", "Date", "Round", "White", "Black", "Result"]

-- Parser for a PGN string token.
pgnString :: Parser String
pgnString = lexeme $ between (char '"') (char '"') (many pgnStringChar)

-- Parser for characters inside a string token.
pgnStringChar :: Parser Char
pgnStringChar = do
  c <- satisfy (\c -> isPrint c && c /= '"')
  if c == '\\'
    then oneOf "\\\""
    else return c

-- The tag name token is a further restricted symbol token.
pgnTagName :: Parser String
pgnTagName = lexeme $ do
  first <- alphaNum
  rest <- many (alphaNum <|> char '_')
  return (first:rest)

-- Parser for a PGN integer token.
pgnInteger :: Parser Integer
pgnInteger = lexeme decimal

-- Parser for PGN tags.
pgnTag :: Parser PGNTag
pgnTag = do
  lexeme (char '[')
  name <- pgnTagName
  val <- pgnString
  lexeme (char ']')
  return (name,val)

-- XXX we should check the move numbers.
pgnMoveNumber :: Parser ()
pgnMoveNumber = do
  pgnInteger
  lexeme (skipMany (char '.'))

pgnMove :: Parser PGNMove
pgnMove = do
  optional pgnMoveNumber
  move <- lexeme sanFullMove
  return move

pgnParser :: Parser PGN
pgnParser = do
  whiteSpace
  tags <- many pgnTag
  when (any isNothing (map (flip lookup tags) pgnSTR)) $
    fail "incomplete tag list"
  moves <- many pgnMove
  string (fromJust (lookup "Result" tags)) -- XXX
  return (PGN tags moves)