-- hsdip -- a diplomacy parser/renderer.
-- Copyright (C) 2006 Evan Martin <martine@danga.com>

module JudgeParser (
  parseFileTurn, parseFileTurns,
  tests
) where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad(liftM)
-- import Debug.Trace
import Data.List (groupBy)
import Test.HUnit

import Diplomacy

p_unit :: Parser Unit
p_unit = do symbol "Army";  return Army
     <|> do symbol "Fleet"; return Fleet

p_location :: Parser String
p_location = do
  parts <- many1 (identifier
              <|> try (char '-' >> notFollowedBy (char '>') >> return "-"))
  return (join parts) where
    join :: [String] -> String
    join [] = ""
    join xs = foldr1 (\a b -> a ++ ' ' : b) xs

p_power :: Parser Power
p_power = do
  power <- choice [reserved x >> return x | x <- powerNames]
  return (read power)

p_unitLocation :: Parser UnitLoc
p_unitLocation = do
  unit <- p_unit; loc <- p_location
  return (unit, loc)

optionally :: GenParser tok st a -> GenParser tok st ()
optionally p = option () (try p >> return ())

optionalLine :: String -> GenParser Char st ()
optionalLine match = optionally $ do
  string match
  manyTill anyChar (char '\n')

p_turn :: Parser Turn
p_turn = do
  optionalLine "From dpjudge"
  optionalLine "Subject: "
  whiteSpace
  p_metaHeader
  (name, time, units, moves) <- p_turnbody
  option () (p_ownership >> return ())
  optionalLine "The next phase"
  optionalLine "The deadline"
  whiteSpace
  return $ Turn {
    turnName = name,
    turnTime = time,
    turnUnits = units,
    turnMoves = moves,
    turnOwnership = []
  }

-- TODO: actually parse the guts of these.
p_metaHeader :: GenParser Char () [[Char]]
p_metaHeader = do h <- many1 headerLine; whiteSpace; return h
  where headerLine = reservedOp "::" >> manyTill anyChar newline

p_turnbody :: Parser (String, Time, [PowerPos], [PowerMove])
p_turnbody = p_body "Starting position" p_movement
         <|> p_body "Movement results"  p_movement
         <|> p_body "Retreat orders"    p_movement
         <|> p_body "Adjustment orders" p_adjustment
  where
    p_body str p = do
      (long, time) <- p_header str
      (units, moves) <- p
      return (long, time, units, moves)
    p_header htype = do
      string htype
      string " for "
      longname <- manyTill anyChar (char '.')
      string "  ("
      identifier
      char '.'
      time <- p_shortTurn
      string ")\n\n"
      return (longname, time)

p_shortTurn :: (Read a) => GenParser Char st (a, Season, TurnType)
p_shortTurn = do
  season <- p_season
  year <- p_year
  ttype <- p_type
  return (year, season, ttype) where
    p_season = do char 'S'; return Spring
           <|> do oneOf "FW"; return Fall
    p_year = liftM read $ many1 digit
    p_type = do char 'M'; return Movement
         <|> do char 'A'; return Adjustment
         <|> do char 'R'; return Retreat

-- Given an input like:
--   Austria: bar.
--   Austria: bar2.
--   Germany: baz.
-- Does the natural grouping, running the parser on the bodies.
-- Returns [(Austria, [results]), (Germany, [results)].
p_powerSet :: Parser a -> Parser [(Power, [a])]
p_powerSet p_body = do
  lnes <- many1 p_one
  let groups = groupBy (\a b -> fst a == fst b) lnes
  return $ map simplify groups
  where
    p_one = do power <- p_power; colon; body <- p_body
               return (power, body)
    simplify lnes = (head powers, body) where (powers, body) = unzip lnes

p_movement :: Parser ([PowerPos], [PowerMove])
p_movement = do
  pmoves <- p_powerSet p_fullMove
  optionally $ do
    string "The following units were dislodged:"; whiteSpace
    skipMany (string "The " >> manyTill anyChar (string ".\n") >> return ())
    whiteSpace
  return (positionsFromMoves pmoves, pmoves) where
    positionsFromMoves = mapPowers (\(UnitMove unitloc _, _) -> unitloc)
    mapPowers f = map (\(power, content) -> (power, map f content))

p_adjustment :: Parser ([PowerPos], [PowerMove])
p_adjustment = do
  p_powerSet p_adjust
  return ([], []) where
    p_adjust = do string "Builds "
                  (char 'a' >> (string "n army" <|> string " fleet"))
                  string " in "
                  p_location
                  period
                  return ()

p_fullMove_test :: Test
p_fullMove_test = TestList $ [
    testParse "Army Liverpool -> Edinburgh."
              (UnitMove (Army, "Liverpool") (Attack "Edinburgh"), False)
  , testParse "Army Marseilles SUPPORT Army Paris -> Burgundy."
              (UnitMove (Army, "Marseilles")
                 (Support (UnitMove (Army, "Paris") (Attack "Burgundy"))),
               False)
  , testParse "Army Bulgaria -> Aegean Sea -> Eastern Mediterranean -> Syria.  (*no convoy*)"
              (UnitMove (Army, "Bulgaria") (Attack "Syria"), True)
  , testParse "Fleet Eastern Mediterranean CONVOY Army Bulgaria -> Syria.  (*void*)"
              (UnitMove (Fleet, "Eastern Mediterranean")
                 (Convoy (UnitMove (Army, "Bulgaria") (Attack "Syria"))),
               True)
  , testParse "Army Serbia SUPPORT Italian Army Bulgaria."
              (UnitMove (Army, "Serbia")
                 (Support (UnitMove (Army, "Bulgaria") Hold)),
               False)
  , testParse "Army Serbia SUPPORT Fleet Trieste -> Albania.  (*cut, dislodged*)"
              (UnitMove (Army, "Serbia")
                 (Support (UnitMove (Fleet, "Trieste") (Attack "Albania"))),
               True)
  ]
  where
    testParse str expr = TestCase $ do
      case (parse p_fullMove "" str) of
        Left err -> assertFailure (show err)
        Right r  -> assertEqual "" expr r

tests :: Test
tests = TestList [p_fullMove_test]

p_fullMove :: Parser UnitMoveTry
p_fullMove = do
  unitmove <- p_unitMove; period
  failed <- option False (p_failed >> return True)
  return (unitmove, failed)
  where
    -- a submove can either be "italian army ..." or just "army ..."
    p_unitMove = try (do identifier; p_unitMove')
            <|> p_unitMove'
    p_unitMove' :: Parser UnitMove
    p_unitMove' = do
      unitloc <- p_unitLocation
      move <- p_movetype
      return $ UnitMove unitloc move
    p_movetype = do reservedOp "->";
                    locs <- p_location `sepBy` (reservedOp "->")
                    return $ Attack (last locs)
             <|> do reserved "SUPPORT"
                    return . Support =<< p_unitMove
             <|> do reserved "CONVOY"
                    return . Convoy =<< p_unitMove
             <|> do reserved "HOLD"; return Hold
             <|> return Hold  -- when you support a hold, there's no HOLD text.
    -- failed looks like:  (* cut, dislodged *)
    p_failed = do reservedOp "(*"; skipMany (identifier <|> comma); reservedOp "*)"

-- Austria:    Budapest, Rumania, Serbia, Trieste, Vienna.

p_ownership :: Parser [Ownership]
p_ownership = do
  string "Ownership of supply centers:\n\n"
  owners <- many (try p_owner)
  many p_build
  return owners where
    p_owner = do
      power <- p_maybePower; colon
      countries <- p_location `sepBy1` comma; period
      return (power, countries)
    p_maybePower = (p_power >>= return . Just)
               <|> (string "Unowned" >> return Nothing)
    p_build = do
      p_power; colon
      number; symbol "Supply centers,"
      number; symbol "Units:"
      (symbol "Builds" <|> symbol "Removes"); _ <- number
      (try (symbol "units") <|> symbol "unit"); period
    number = lexeme decimal

simplifyError :: Either ParseError a -> Either String a
simplifyError (Left x) = Left $ show x
simplifyError (Right a) = Right a

parseFullFile :: GenParser Char () a -> SourceName -> IO (Either ParseError a)
parseFullFile p = parseFromFile (do x <- p; eof; return x)

parseFileTurn :: SourceName -> IO (Either String Turn)
parseFileTurn = liftM simplifyError . parseFullFile p_turn

parseFileTurns :: SourceName -> IO (Either String [Turn])
parseFileTurns = liftM simplifyError . parseFullFile (many1 p_turn)

dipLanguage :: LanguageDef st
dipLanguage = emptyDef {
  identStart  = identStart emptyDef <|> oneOf "()",
  identLetter = identLetter emptyDef <|> oneOf "()",
  opStart  = oneOf ":-.(*",
  opLetter = opStart dipLanguage <|> oneOf ">*)",
  reservedNames  = ["SUPPORT", "CONVOY", "HOLD"] ++ powerNames,
  reservedOpNames = [":", "::", "->", ".", "(*", "*)"]
}
lexer :: P.TokenParser ()
lexer = P.makeTokenParser dipLanguage
whiteSpace :: CharParser () ()
whiteSpace = P.whiteSpace lexer


lexeme :: CharParser () a -> CharParser () a
lexeme = P.lexeme lexer
reservedOp :: String -> CharParser () ()
reservedOp = P.reservedOp lexer
reserved :: String -> CharParser () ()
reserved = P.reserved lexer
identifier :: CharParser () String
identifier = P.identifier lexer
symbol :: String -> CharParser () String
symbol = P.symbol lexer
colon :: CharParser () String
colon  = P.colon lexer
comma :: CharParser () String
comma  = P.comma lexer
period :: CharParser () String
period = P.dot lexer
decimal :: CharParser () Integer
decimal = P.decimal lexer
-- natural = P.natural lexer

-- vim: set ts=2 sw=2 et :