{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Debug.Trace

import Control.Applicative (many, liftA2)
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Either (isLeft)
import qualified Data.Text as T
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.Runners as Tasty
import Test.Tasty.QuickCheck ((===))
import qualified Test.Tasty.QuickCheck as QC
import qualified Test.Tasty.HUnit as HU
import           Test.Tasty.HUnit ((@?=), (@=?))
import qualified Test.QuickCheck.Instances ()

import qualified Xmlbf as X

--------------------------------------------------------------------------------

main :: IO ()
main = Tasty.defaultMainWithIngredients
  [ Tasty.consoleTestReporter
  , Tasty.listingTests
  ] tt_main

--------------------------------------------------------------------------------
tt_main :: Tasty.TestTree
tt_main = Tasty.testGroup "main"
  [ tt_element
  , tt_encoding
  , tt_parsing
  , tt_fixpoints
  ]

tt_element :: Tasty.TestTree
tt_element = Tasty.testGroup "element"
  [ HU.testCase "empty name" $ do
      HU.assert (isLeft (X.element "" [] []))

  , HU.testCase "name with leading whitespace" $ do
      HU.assert (isLeft (X.element " x" [] []))

  , HU.testCase "name with trailing whitespace" $ do
      HU.assert (isLeft (X.element "x " [] []))

  , HU.testCase "empty attribute" $ do
      HU.assert (isLeft (X.element "x" [("","a")] []))

  , HU.testCase "attribute with leading whitespace" $ do
      HU.assert (isLeft (X.element "x" [(" x","a")] []))

  , HU.testCase "attribute with trailing whitespace" $ do
      HU.assert (isLeft (X.element "x" [("x ","a")] []))
  ]

tt_encoding :: Tasty.TestTree
tt_encoding = Tasty.testGroup "Encoding"
  [ HU.testCase "" $ do
      bsEncode [] @?= ""

  , HU.testCase "<x a=\"y\"/>" $ do
      let n0 = X.element' "x" [("a","y")] []
      bsEncode [n0] @?= "<x a=\"y\"/>"

  , HU.testCase "<x a=\"y\" b=\"\"/>" $ do
      let n0 = X.element' "x" [("a","y"), ("b","")] []
      bsEncode [n0] @?= "<x a=\"y\" b=\"\"/>"

  , HU.testCase "<x a=\"y\" b=\"z\"/>" $ do
      let n0 = X.element' "x" [("a","y"), ("b","z")] []
      bsEncode [n0] @?= "<x a=\"y\" b=\"z\"/>"

  , HU.testCase "<x a=\"y\" b=\"z\"></x>" $ do
      let n0 = X.element' "x" [("a","y"), ("b","z")] [X.text ""]
      bsEncode [n0] @?= "<x a=\"y\" b=\"z\"></x>"

  , HU.testCase "<x>foo</x>" $ do
      let n0 = X.element' "x" [] [X.text "foo"]
      bsEncode [n0] @?= "<x>foo</x>"

  , HU.testCase "<x>foobar</x>" $ do
      let n0 = X.element' "x" [] [X.text "foo", X.text "bar"]
      bsEncode [n0] @?= "<x>foobar</x>"

  , HU.testCase "<x><y/></x>" $ do
      let n0 = X.element' "x" [] [X.element' "y" [] []]
      bsEncode [n0] @?= "<x><y/></x>"

  , HU.testCase "<x><y/></x>" $ do
      let n0 = X.element' "x" []
                  [X.text "", X.element' "y" [] [], X.text ""]
      bsEncode [n0] @?= "<x><y/></x>"

  , HU.testCase "<x><y/><z/></x>" $ do
      let n0 = X.element' "x" []
                  [X.element' "y" [] [], X.element' "z" [] []]
      bsEncode [n0] @?= "<x><y/><z/></x>"

  , HU.testCase "<x><y>" $ do
      let n0 = X.element' "x" [] []
          n1 = X.element' "y" [] []
      bsEncode [n0,n1] @?= "<x/><y/>"
  ]

--------------------------------------------------------------------------------

tt_parsing :: Tasty.TestTree
tt_parsing = Tasty.testGroup "Parsing"
  [ HU.testCase "endOfInput" $ do
      Right () @=? X.runParser X.pEndOfInput []

  , HU.testCase "endOfInput: Not end of input yet" $ do
      Left "Not end of input yet" @=? X.runParser X.pEndOfInput [X.text "&"]

  , HU.testCase "text: empty" $ do
      Left "Missing text node" @=? X.runParser X.pText []

  , HU.testCase "text: Missing text node" $ do
      Left "Missing text node" @=? X.runParser X.pText [X.element' "a" [] []]

  , HU.testCase "text" $ do
      Right "&" @=? X.runParser X.pText [X.text "&"]

  , HU.testCase "text: concat" $ do
      Right "&<" @=? X.runParser X.pText
         [X.text "&", X.text "", X.text "<"]

  , HU.testCase "text: twice" $ do
      Left "Missing text node" @=? X.runParser (X.pText >> X.pText)
         [X.text "&", X.text "", X.text "<"]

  , HU.testCase "element: empty" $ do
      Left "Missing element \"x\"" @=? X.runParser (X.pElement "x" (pure ())) []

  , HU.testCase "element: Missing element" $ do
      Left "Missing element \"x\""
         @=? X.runParser (X.pElement "x" (pure ())) [X.element' "y" [] []]

  , HU.testCase "element: pure" $ do
      Right ()
         @=? X.runParser (X.pElement "x" (pure ())) [X.element' "x" [] []]

  , HU.testCase "element: leading whitespace" $ do
      Right ()
         @=? X.runParser (X.pElement "x" (pure ()))
                         [X.text " \n \t", X.element' "x" [] []]

  , HU.testCase "element: text" $ do
      Right "ab"
        @=? X.runParser (X.pElement "x" X.pText)
                [X.element' "x" [] [X.text "a", X.text "b"]]

  , HU.testCase "element: nested" $ do
      Right ([("a","b")], "z")
        @=? X.runParser
                (X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText)))
                [X.element' "x" [] [X.element' "y" [("a","b")] [X.text "z"]]]

  , HU.testCase "element: nested with leading whitespace" $ do
      Right ([("a","b")], "z")
        @=? X.runParser
                (X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText)))
                [X.text " ", X.element' "x" [] [X.text " ", X.element' "y" [("a","b")] [X.text "z"]]]

  , HU.testCase "attr" $ do
      Right "a"
         @=? X.runParser (X.pElement "x" (X.pAttr "y"))
                [X.element' "x" [("y","a"), ("z","b")] []]

  , HU.testCase "attr: Missing" $ do
      Left "Missing attribute \"y\""
         @=? X.runParser (X.pElement "x" (X.pAttr "y")) [X.element' "x" [] []]

  , HU.testCase "attrs: empty" $ do
      Right []
         @=? X.runParser (X.pElement "x" X.pAttrs) [X.element' "x" [] []]

  , HU.testCase "attrs" $ do
      Right [("y","a"), ("z","b")]
         @=? X.runParser (X.pElement "x" X.pAttrs)
                [X.element' "x" [("z","b"), ("y","a")] []]

  , HU.testCase "read" $ do
      Right False @=? X.runParser (X.pRead =<< X.pText) [X.text "False"]
      (Left "Can't read as Bool: \"XXXXX\"" :: Either String Bool)
        @=? X.runParser (X.pRead =<< X.pText) [X.text "XXXXX"]
  ]


node0 :: X.Node
node0 =
  X.element' "a" []
   [ X.element' "b" []
      [ X.element' "c" [] []
      , X.element' "d" [] [] ]
   , X.element' "e" []
      [ X.element' "f" [] []
      , X.element' "g" [] [] ] ]


fixvisit :: (X.Node -> S.State T.Text [X.Node])
         -> (X.Node -> S.State T.Text [X.Node])
fixvisit k n@(X.Element t _ _) = do
   S.modify (\ts -> mappend ts t)
   pure [n]

tt_fixpoints :: Tasty.TestTree
tt_fixpoints = Tasty.testGroup "fixpoints"
  [ HU.testCase "dfpos: depth-first post-order?" $ do
      let (ns, ts) = S.runState (X.dfposM fixvisit node0) []
      ns @?= [node0]
      ts @?= "cdbfgea"

  , HU.testCase "dfpos: output single node" $ do
      let n0 = X.element' "x" [] [X.text "a", X.text "b"]
          f = \k -> \case
             X.Text "ab" -> k (X.text "foo")
             X.Text "foo" -> k (X.text "FOO")
             n -> [n]
          n1 = X.element' "x" [] [X.text "FOO"]
      [n1] @?= X.dfpos f n0

  , HU.testCase "dfpos: output multiple nodes" $ do
      let n0 = X.element' "x" [] [X.text "a"]
          f = \k -> \case
             X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k
             X.Element "y" _ _ -> k (X.text "b")
             X.Element "x" as cs  ->
                let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k
             n -> [n]
          ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"]
      ns1 @?= X.dfpos f n0

  , HU.testCase "dfpre: depth-first pre-order?" $ do
      let (ns, ts) = S.runState (X.dfpreM fixvisit node0) []
      ns @?= [node0]
      ts @?= "abcdefg"

  , HU.testCase "dfpre: output single node" $ do
      let n0 = X.element' "x" [] [X.text "a", X.text "b"]
          f = \k -> \case
             X.Text "ab" -> k (X.text "foo")
             X.Text "foo" -> k (X.text "FOO")
             n -> [n]
          n1 = X.element' "x" [] [X.text "FOO"]
      [n1] @?= X.dfpre f n0

  , HU.testCase "dfpre: output multiple nodes" $ do
      let n0 = X.element' "x" [] [X.text "a"]
          f = \k -> \case
             X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k
             X.Element "y" _ _ -> k (X.text "b")
             X.Element "x" as cs  ->
                let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k
             n -> [n]
          ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"]
      ns1 @?= X.dfpre f n0
  ]

--------------------------------------------------------------------------------

bsEncode :: [X.Node] -> B.ByteString
bsEncode = BL.toStrict . BB.toLazyByteString . X.encode