-- This file is part of Goatee.
--
-- Copyright 2014 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/>.

module Game.Goatee.Sgf.ParserTest (tests) where

import Control.Monad (forM_)
import Game.Goatee.Sgf.ParserTestUtils
import Game.Goatee.Sgf.Property
import Game.Goatee.Sgf.TestInstances ()
import Game.Goatee.Sgf.TestUtils
import Game.Goatee.Sgf.Tree
import Game.Goatee.Sgf.Types
import Test.Framework (testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit ((@?=))

tests = testGroup "Game.Goatee.Sgf.Parser" [
  baseCaseTests,
  whitespaceTests,
  passConversionTests,
  movePropertyTests,
  setupPropertyTests,
  nodeAnnotationPropertyTests,
  moveAnnotationPropertyTests,
  rootPropertyTests
  ]

baseCaseTests = testGroup "base cases" [
  testCase "works with the trivial collection" $
    parseOrFail "(;)" (@?= emptyNode),

  testCase "works with only a size property" $ do
    parseOrFail "(;SZ[1])" (@?= root 1 1 [] [])
    parseOrFail "(;SZ[9])" (@?= root 9 9 [] [])
  ]

whitespaceTests = testGroup "whitespace handling" [
  testCase "parses with no extra whitespace" $
    parseOrFail "(;SZ[4];AB[aa][bb]AW[cc];W[dd])"
    (@?= root 4 4 [] [node1 [AB $ coords [(0,0), (1,1)], AW $ coords [(2,2)]] $
                      node [W $ Just (3,3)]]),

  testCase "parses with spaces between nodes" $
    parseOrFail "(;SZ[1] ;B[])" (@?= root 1 1 [] [node [B Nothing]]),

  testCase "parses with spaces between properties" $
    parseOrFail "(;SZ[1] AB[aa])" (@?= root 1 1 [AB $ coords [(0,0)]] []),

  testCase "parses with spaces between a property's name and value" $
    parseOrFail "(;SZ [1])" (@?= root 1 1 [] []),

  testCase "parses with spaces between property values" $
    parseOrFail "(;SZ[2]AB[aa] [bb])" (@?= root 2 2 [AB $ coords [(0,0), (1,1)]] []),

  testCase "parses with spaces between many elements" $
    parseOrFail " ( ; SZ [4] ; AB [aa:ad] [bb] AW [cc] ; W [dd] ; B [] ) "
    (@?= root 4 4 [] [node1 [AB $ coords' [(1,1)] [((0,0), (0,3))],
                             AW $ coords [(2,2)]] $
                      node1 [W $ Just (3,3)] $
                      node [B Nothing]])

  -- TODO Test handling of whitespace between an unknown property name and
  -- [value].
  ]

passConversionTests = testGroup "B[tt]/W[tt] pass conversion" [
  testCase "converts B[tt] for a board sizes <=19x19" $ do
    parseOrFail "(;SZ[1];B[tt])" (@?= root 1 1 [] [node [B Nothing]])
    parseOrFail "(;SZ[9];B[tt])" (@?= root 9 9 [] [node [B Nothing]])
    parseOrFail "(;SZ[19];B[tt])" (@?= root 19 19 [] [node [B Nothing]]),

  testCase "converts W[tt] for a board sizes <=19x19" $ do
    parseOrFail "(;SZ[1];W[tt])" (@?= root 1 1 [] [node [W Nothing]])
    parseOrFail "(;SZ[9];W[tt])" (@?= root 9 9 [] [node [W Nothing]])
    parseOrFail "(;SZ[19];W[tt])" (@?= root 19 19 [] [node [W Nothing]]),

  testCase "doesn't convert B[tt] for a board sizes >19x19" $ do
    parseOrFail "(;SZ[20];B[tt])" (@?= root 20 20 [] [node [B $ Just (19, 19)]])
    parseOrFail "(;SZ[21];B[tt])" (@?= root 21 21 [] [node [B $ Just (19, 19)]]),

  testCase "doesn't convert W[tt] for a board sizes >19x19" $ do
    parseOrFail "(;SZ[20];W[tt])" (@?= root 20 20 [] [node [W $ Just (19, 19)]])
    parseOrFail "(;SZ[21];W[tt])" (@?= root 21 21 [] [node [W $ Just (19, 19)]]),

  testCase "doesn't convert non-move properties" $ do
    -- TODO These should error, rather than parsing fine.
    parseOrFail "(;SZ[9];AB[tt])" (@?= root 9 9 [] [node [AB $ coords [(19, 19)]]])
    parseOrFail "(;SZ[9];TR[tt])" (@?= root 9 9 [] [node [TR $ coords [(19, 19)]]])
  ]

movePropertyTests = testGroup "move properties" [
  testGroup "B" [
    testCase "parses moves" $ do
      parseOrFail "(;B[aa])" (@?= node [B $ Just (0, 0)])
      parseOrFail "(;B[cp])" (@?= node [B $ Just (2, 15)]),
    testCase "parses passes" $
      parseOrFail "(;B[])" (@?= node [B Nothing])
    ],
  testCase "KO parses" $
    parseOrFail "(;KO[])" (@?= node [KO]),
  -- TODO Test MN (assert positive).
  testGroup "W" [
    testCase "parses moves" $ do
      parseOrFail "(;W[aa])" (@?= node [W $ Just (0, 0)])
      parseOrFail "(;W[cp])" (@?= node [W $ Just (2, 15)]),
    testCase "parses passes" $
      parseOrFail "(;W[])" (@?= node [W Nothing])
    ]
  ]

setupPropertyTests = testGroup "setup properties" [
  testCase "AB parses" $ do
    parseOrFail "(;AB[ab])" (@?= node [AB $ coords [(0, 1)]])
    parseOrFail "(;AB[ab][cd:ef])" (@?= node [AB $ coords' [(0, 1)] [((2, 3), (4, 5))]]),
  testCase "AE parses" $ do
    parseOrFail "(;AE[ae])" (@?= node [AE $ coords [(0, 4)]])
    parseOrFail "(;AE[ae][ff:gg])" (@?= node [AE $ coords' [(0, 4)] [((5, 5), (6, 6))]]),
  testCase "AW parses" $ do
    parseOrFail "(;AW[aw])" (@?= node [AW $ coords [(0, 22)]])
    parseOrFail "(;AW[aw][xy:yz])" (@?= node [AW $ coords' [(0, 22)] [((23, 24), (24, 25))]]),
  testCase "PL parses" $ do
    parseOrFail "(;PL[B])" (@?= node [PL Black])
    parseOrFail "(;PL[W])" (@?= node [PL White])
  ]

nodeAnnotationPropertyTests = testGroup "node annotation properties" [
  testCase "C parses" $
    parseOrFail "(;C[Me [30k\\]: What is White doing??\\\n\n:(])"
      (@?= node [C $ toText "Me [30k]: What is White doing??\n:("]),
  testCase "DM parses" $ do
    parseOrFail "(;DM[1])" (@?= node [DM Double1])
    parseOrFail "(;DM[2])" (@?= node [DM Double2]),
  testCase "GB parses" $ do
    parseOrFail "(;GB[1])" (@?= node [GB Double1])
    parseOrFail "(;GB[2])" (@?= node [GB Double2]),
  testCase "GW parses" $ do
    parseOrFail "(;GW[1])" (@?= node [GW Double1])
    parseOrFail "(;GW[2])" (@?= node [GW Double2]),
  testCase "HO parses" $ do
    parseOrFail "(;HO[1])" (@?= node [HO Double1])
    parseOrFail "(;HO[2])" (@?= node [HO Double2]),
  testCase "N parses" $
    parseOrFail "(;N[The best\\\n\nmove])" (@?= node [N $ toSimpleText "The best move"]),
  testCase "UC parses" $ do
    parseOrFail "(;UC[1])" (@?= node [UC Double1])
    parseOrFail "(;UC[2])" (@?= node [UC Double2]),
  testCase "V parses" $ do
    parseOrFail "(;V[-34.5])" (@?= node [V (-34.5)])
    parseOrFail "(;V[50])" (@?= node [V 50])
  ]

moveAnnotationPropertyTests = testGroup "move annotation properties" [
  testCase "BM parses" $ do
    parseOrFail "(;BM[1])" (@?= node [BM Double1])
    parseOrFail "(;BM[2])" (@?= node [BM Double2]),
  testCase "DO parses" $
    parseOrFail "(;DO[])" (@?= node [DO]),
  testCase "IT parses" $
    parseOrFail "(;IT[])" (@?= node [IT]),
  testCase "TE parses" $ do
    parseOrFail "(;TE[1])" (@?= node [TE Double1])
    parseOrFail "(;TE[2])" (@?= node [TE Double2])
  ]

-- TODO Test markup properties.

rootPropertyTests = testGroup "root properties" [
  testCase "AP parses" $
    parseOrFail "(;AP[GoGoGo:1.2.3])"
    (@?= node [AP (toSimpleText "GoGoGo") (toSimpleText "1.2.3")]),
  testCase "CA parses" $ do
    parseOrFail "(;CA[UTF-8])" (@?= node [CA $ toSimpleText "UTF-8"])
    parseOrFail "(;CA[ISO-8859-1])" (@?= node [CA $ toSimpleText "ISO-8859-1"]),
  testGroup "FF" [
    testCase "accepts version 4" $
      parseOrFail "(;FF[4])" (@?= node [FF 4]),
    testCase "rejects versions 1-3" $ do
      parseAndFail "(;FF[1])"
      parseAndFail "(;FF[2])"
      parseAndFail "(;FF[3])"
    ],
  testGroup "GM" [
    testCase "parses 1 (Go)" $
      parseOrFail "(;GM[1])" (@?= node [GM 1]),
    testCase "rejects unsupported games" $
      forM_ [2..16] $ \x -> parseAndFail $ "(;GM[" ++ show x ++ "]"
    ],
  testGroup "ST" [
    testCase "parses valid variation modes" $ do
      parseOrFail "(;ST[0])" (@?= node [ST $ VariationMode ShowChildVariations True])
      parseOrFail "(;ST[1])" (@?= node [ST $ VariationMode ShowCurrentVariations True])
      parseOrFail "(;ST[2])" (@?= node [ST $ VariationMode ShowChildVariations False])
      parseOrFail "(;ST[3])" (@?= node [ST $ VariationMode ShowCurrentVariations False]),
    testCase "rejects invalid variation modes" $
      forM_ [4..10] $ \x -> parseAndFail $ "(;ST[" ++ show x ++ "]"
    ],
  testGroup "SZ" [
    testCase "parses square boards" $
      forM_ [1..52] $ \x ->
        parseOrFail ("(;SZ[" ++ show x ++ "])") (@?= node [SZ x x]),
    testCase "parses nonsquare boards" $ do
      parseOrFail "(;SZ[1:2])" (@?= node [SZ 1 2])
      parseOrFail "(;SZ[1:9])" (@?= node [SZ 1 9])
      parseOrFail "(;SZ[1:19])" (@?= node [SZ 1 19])
      parseOrFail "(;SZ[2:1])" (@?= node [SZ 2 1])
      parseOrFail "(;SZ[9:1])" (@?= node [SZ 9 1])
      parseOrFail "(;SZ[19:1])" (@?= node [SZ 19 1])
      parseOrFail "(;SZ[19:52])" (@?= node [SZ 19 52])
      parseOrFail "(;SZ[10:16])" (@?= node [SZ 10 16]),
    testCase "rejects invalid sizes" $ do
      -- Boards must have length at least 1...
      parseAndFail "(;SZ[0])"
      parseAndFail "(;SZ[-1])"
      -- ...and at most 52.
      parseAndFail "(;SZ[53])"
      parseAndFail "(;SZ[54])"
      parseAndFail "(;SZ[0:19])"
      parseAndFail "(;SZ[19:0])"
      parseAndFail "(;SZ[9:53])"
      parseAndFail "(;SZ[53:9])",
    -- This is specified by the SGF spec:
    testCase "rejects square boards defined with two numbers" $ do
      parseAndFail "(;SZ[1:1])"
      parseAndFail "(;SZ[19:19])"
    ]
  ]

-- TODO Test the test of the properties.