{-# LANGUAGE CPP #-}
module Game.Goatee.Lib.Parser (
parseString,
parseFile,
parseSubtree,
propertyParser,
) where
import Control.Arrow ((+++))
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 :: String -> Either String Collection
parseString String
str = case Parsec String () Collection
-> String -> String -> Either ParseError Collection
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () Collection
collectionParser String
"<collection>" String
str of
Left ParseError
err -> String -> Either String Collection
forall a b. a -> Either a b
Left (String -> Either String Collection)
-> String -> Either String Collection
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
Right (Collection [Node]
roots) -> ([String] -> String
forall (t :: * -> *). Foldable t => t String -> String
concatErrors ([String] -> String)
-> ([Node] -> Collection)
-> Either [String] [Node]
-> Either String Collection
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ [Node] -> Collection
Collection) (Either [String] [Node] -> Either String Collection)
-> Either [String] [Node] -> Either String Collection
forall a b. (a -> b) -> a -> b
$
[Either String Node] -> Either [String] [Node]
forall a b. [Either a b] -> Either [a] [b]
andEithers ([Either String Node] -> Either [String] [Node])
-> [Either String Node] -> Either [String] [Node]
forall a b. (a -> b) -> a -> b
$
(Node -> Either String Node) -> [Node] -> [Either String Node]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Either String Node
processRoot [Node]
roots
where processRoot :: Node -> Either String Node
processRoot :: Node -> Either String Node
processRoot = Node -> Either String Node
checkFormatVersion (Node -> Either String Node)
-> (Node -> Node) -> Node -> Either String Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Node
root ->
let SZ Int
width Int
height = Property -> Maybe Property -> Property
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Property
SZ Int
boardSizeDefault Int
boardSizeDefault) (Maybe Property -> Property) -> Maybe Property -> Property
forall a b. (a -> b) -> a -> b
$
ValuedPropertyInfo (Int, Int) -> Node -> Maybe Property
forall a. Descriptor a => a -> Node -> Maybe Property
findProperty ValuedPropertyInfo (Int, Int)
propertySZ Node
root
in Int -> Int -> Node -> Node
postProcessTree Int
width Int
height Node
root
concatErrors :: t String -> String
concatErrors t String
errs = String
"The following errors occurred while parsing:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(String -> String) -> t String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
"\n-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++) t String
errs
parseFile :: String -> IO (Either String Collection)
parseFile :: String -> IO (Either String Collection)
parseFile = (String -> Either String Collection)
-> IO String -> IO (Either String Collection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either String Collection
parseString (IO String -> IO (Either String Collection))
-> (String -> IO String) -> String -> IO (Either String Collection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile
parseSubtree :: RootInfo -> String -> Either String Node
parseSubtree :: RootInfo -> String -> Either String Node
parseSubtree RootInfo
rootInfo String
str =
case Parsec String () Node -> String -> String -> Either ParseError Node
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> Parsec String () Node -> Parsec String () Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String () Node
gameTreeParser Parsec String () Node
-> ParsecT String () Identity () -> Parsec String () Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) String
"<gameTree>" String
str of
Left ParseError
err -> String -> Either String Node
forall a b. a -> Either a b
Left (String -> Either String Node) -> String -> Either String Node
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
Right Node
node ->
let width :: Int
width = RootInfo -> Int
rootInfoWidth RootInfo
rootInfo
height :: Int
height = RootInfo -> Int
rootInfoHeight RootInfo
rootInfo
in Node -> Either String Node
forall a b. b -> Either a b
Right (Node -> Either String Node) -> Node -> Either String Node
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Node -> Node
postProcessTree Int
width Int
height Node
node
checkFormatVersion :: Node -> Either String Node
checkFormatVersion :: Node -> Either String Node
checkFormatVersion Node
root =
let version :: Int
version = case ValuedPropertyInfo Int -> Node -> Maybe Property
forall a. Descriptor a => a -> Node -> Maybe Property
findProperty ValuedPropertyInfo Int
propertyFF Node
root of
Maybe Property
Nothing -> Int
defaultFormatVersion
Just (FF Int
x) -> Int
x
Maybe Property
x -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"Expected FF or nothing, received " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Property -> String
forall a. Show a => a -> String
show Maybe Property
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
in if Int
version Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
supportedFormatVersions
then Node -> Either String Node
forall a b. b -> Either a b
Right Node
root
else String -> Either String Node
forall a b. a -> Either a b
Left (String -> Either String Node) -> String -> Either String Node
forall a b. (a -> b) -> a -> b
$
String
"Unsupported SGF version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Only versions " String -> String -> String
forall a. [a] -> [a] -> [a]
++
[Int] -> String
forall a. Show a => a -> String
show [Int]
supportedFormatVersions String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" are supported."
postProcessTree :: Int -> Int -> Node -> Node
postProcessTree :: Int -> Int -> Node -> Node
postProcessTree Int
width Int
height Node
node =
if Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
19 Bool -> Bool -> Bool
&& Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
19 then Node -> Node
convertNodeTtToPass Node
node else Node
node
convertNodeTtToPass :: Node -> Node
convertNodeTtToPass :: Node -> Node
convertNodeTtToPass Node
node =
Node
node { nodeProperties :: [Property]
nodeProperties = (Property -> Property) -> [Property] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Property
convertPropertyTtToPass ([Property] -> [Property]) -> [Property] -> [Property]
forall a b. (a -> b) -> a -> b
$ Node -> [Property]
nodeProperties Node
node
, nodeChildren :: [Node]
nodeChildren = (Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Node
convertNodeTtToPass ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
nodeChildren Node
node
}
convertPropertyTtToPass :: Property -> Property
convertPropertyTtToPass :: Property -> Property
convertPropertyTtToPass Property
prop = case Property
prop of
B (Just (Int
19, Int
19)) -> Maybe (Int, Int) -> Property
B Maybe (Int, Int)
forall a. Maybe a
Nothing
W (Just (Int
19, Int
19)) -> Maybe (Int, Int) -> Property
W Maybe (Int, Int)
forall a. Maybe a
Nothing
Property
_ -> Property
prop
collectionParser :: Parser Collection
collectionParser :: Parsec String () Collection
collectionParser =
([Node] -> Collection)
-> ParsecT String () Identity [Node] -> Parsec String () Collection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Node] -> Collection
Collection (ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity [Node]
-> ParsecT String () Identity [Node]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String () Node -> ParsecT String () Identity [Node]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Parsec String () Node
gameTreeParser Parsec String () Node
-> ParsecT String () Identity () -> Parsec String () Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT String () Identity [Node]
-> ParsecT String () Identity ()
-> ParsecT String () Identity [Node]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) Parsec String () Collection
-> String -> Parsec String () Collection
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?>
String
"collection"
gameTreeParser :: Parser Node
gameTreeParser :: Parsec String () Node
gameTreeParser = do
Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
[Node]
nodes <- ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity [Node]
-> ParsecT String () Identity [Node]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String () Node -> ParsecT String () Identity [Node]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Parsec String () Node
nodeParser Parsec String () Node
-> ParsecT String () Identity () -> Parsec String () Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT String () Identity [Node]
-> String -> ParsecT String () Identity [Node]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"sequence"
[Node]
subtrees <- Parsec String () Node -> ParsecT String () Identity [Node]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Parsec String () Node
gameTreeParser Parsec String () Node
-> ParsecT String () Identity () -> Parsec String () Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT String () Identity [Node]
-> String -> ParsecT String () Identity [Node]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"subtrees"
Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
let ([Node]
sequence, [Node
final]) = Int -> [Node] -> ([Node], [Node])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Node]
nodes
Node -> Parsec String () Node
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> Parsec String () Node) -> Node -> Parsec String () Node
forall a b. (a -> b) -> a -> b
$ (Node -> Node -> Node) -> Node -> [Node] -> Node
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node
seqNode Node
childNode -> Node
seqNode { nodeChildren :: [Node]
nodeChildren = [Node
childNode] })
(Node
final { nodeChildren :: [Node]
nodeChildren = [Node]
subtrees })
[Node]
sequence
nodeParser :: Parser Node
nodeParser :: Parsec String () Node
nodeParser =
([Property] -> Node)
-> ParsecT String () Identity [Property] -> Parsec String () Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Property]
props -> Node
emptyNode { nodeProperties :: [Property]
nodeProperties = [Property]
props })
(Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';' ParsecT String () Identity Char
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity [Property]
-> ParsecT String () Identity [Property]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Property
-> ParsecT String () Identity [Property]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Property
propertyParser ParsecT String () Identity Property
-> ParsecT String () Identity ()
-> ParsecT String () Identity Property
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) ParsecT String () Identity [Property]
-> String -> ParsecT String () Identity [Property]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?>
String
"node")
propertyParser :: Parser Property
propertyParser :: ParsecT String () Identity Property
propertyParser = do
String
name <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
upper
ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
AnyDescriptor -> ParsecT String () Identity Property
forall a. Descriptor a => a -> ParsecT String () Identity Property
propertyValueParser (AnyDescriptor -> ParsecT String () Identity Property)
-> AnyDescriptor -> ParsecT String () Identity Property
forall a b. (a -> b) -> a -> b
$ String -> AnyDescriptor
descriptorForName String
name