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 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 = []
}
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
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
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
p_failed = do reservedOp "(*"; skipMany (identifier <|> comma); reservedOp "*)"
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