-- This file is part of Goatee.
--
-- Copyright 2014-2021 Bryan Gardiner
--
-- Goatee is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Goatee is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | A parser for reading SGF files.
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,
  )

-- | Parses a string in SGF format.  Returns an error string if parsing fails.
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

-- | Parses a file in SGF format.  Returns an error string if parsing fails.
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

-- | Parses a node as part of an existing game tree, from textual SGF
-- \"GameTree\" syntax.  The 'RootInfo' is needed to supply necessary
-- information from the existing game tree.
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

-- Ensures that we are parsing an SGF version that we understand.
-- TODO Try to proceed, if it makes sense.
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 =
  -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19.
  -- Convert any passes from this format to B[] and W[] in a root node and
  -- its descendents.
  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