module Game.Goatee.Lib.Parser (
parseString,
parseFile,
parseSubtree,
propertyParser,
) where
import Control.Arrow ((+++))
import Control.Applicative ((<*), (*>))
import Data.Maybe (fromMaybe)
import Game.Goatee.Common
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Tree
import Game.Goatee.Lib.Types
import Text.ParserCombinators.Parsec (
(<?>), Parser, char, eof, many, many1, parse, spaces, upper,
)
parseString :: String -> Either String Collection
parseString str = case parse collectionParser "<collection>" str of
Left err -> Left $ show err
Right (Collection roots) -> (concatErrors +++ Collection) $
andEithers $
map processRoot roots
where processRoot :: Node -> Either String Node
processRoot = checkFormatVersion . \root ->
let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $
findProperty propertySZ root
in postProcessTree width height root
concatErrors errs = "The following errors occurred while parsing:" ++
concatMap ("\n-> " ++) errs
parseFile :: String -> IO (Either String Collection)
parseFile = fmap parseString . readFile
parseSubtree :: RootInfo -> String -> Either String Node
parseSubtree rootInfo str =
case parse (spaces *> gameTreeParser <* spaces) "<gameTree>" str of
Left err -> Left $ show err
Right node ->
let width = rootInfoWidth rootInfo
height = rootInfoHeight rootInfo
in Right $ postProcessTree width height node
checkFormatVersion :: Node -> Either String Node
checkFormatVersion root =
let version = case findProperty propertyFF root of
Nothing -> defaultFormatVersion
Just (FF x) -> x
x -> error $ "Expected FF or nothing, received " ++ show x ++ "."
in if version `elem` supportedFormatVersions
then Right root
else Left $
"Unsupported SGF version " ++ show version ++ ". Only versions " ++
show supportedFormatVersions ++ " are supported."
postProcessTree :: Int -> Int -> Node -> Node
postProcessTree width height node =
if width <= 19 && height <= 19 then convertNodeTtToPass node else node
convertNodeTtToPass :: Node -> Node
convertNodeTtToPass node =
node { nodeProperties = map convertPropertyTtToPass $ nodeProperties node
, nodeChildren = map convertNodeTtToPass $ nodeChildren node
}
convertPropertyTtToPass :: Property -> Property
convertPropertyTtToPass prop = case prop of
B (Just (19, 19)) -> B Nothing
W (Just (19, 19)) -> W Nothing
_ -> prop
collectionParser :: Parser Collection
collectionParser =
fmap Collection (spaces *> many (gameTreeParser <* spaces) <* eof) <?>
"collection"
gameTreeParser :: Parser Node
gameTreeParser = do
char '('
nodes <- spaces *> many1 (nodeParser <* spaces) <?> "sequence"
subtrees <- many (gameTreeParser <* spaces) <?> "subtrees"
char ')'
let (sequence, [final]) = splitAt (length nodes 1) nodes
return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] })
(final { nodeChildren = subtrees })
sequence
nodeParser :: Parser Node
nodeParser =
fmap (\props -> emptyNode { nodeProperties = props })
(char ';' *> spaces *> many (propertyParser <* spaces) <?>
"node")
propertyParser :: Parser Property
propertyParser = do
name <- many1 upper
spaces
propertyValueParser $ descriptorForName name