{-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE OverloadedStrings, RankNTypes #-}

import Control.Exception (throw)
import System.Environment (getArgs)
import System.FilePath

import qualified Data.ByteString as BS

import Data.Text (Text)
import qualified Data.Text as T

import qualified Data.List as List
import Data.Char (isSpace)
import Data.IORef (IORef)

import Text.Roundtrip
import Text.Roundtrip.Xml
import Text.Roundtrip.Xml.Enumerator

import Data.Enumerator
import Data.Enumerator.Binary (enumFile)
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)

import Test.Framework

--
-- Parsing, invalid lookahead, David, 2011-07-23
--

pilSpec1 :: XmlSyntax d => d (Either [Text] [Text])
pilSpec1 =
    xmlElem "root"
    (xmlElem "list" (left <$> many1 (xmlElem "foo" xmlText)) <||>
     xmlElem "list" (right <$> many (xmlElem "bar" xmlText)))

pilSpec2 :: XmlSyntax d => d (Either [Text] [Text])
pilSpec2 =
    xmlElem "root"
    (xmlElem "list" ((left <$> many1 (xmlElem "foo" xmlText)) <|>
                     (right <$> many (xmlElem "bar" xmlText))))

prop_pilSpec1Roundtrip :: Either [Text] [Text] -> Property
prop_pilSpec1Roundtrip arg =
    (case arg of
       Left [] -> False
       _ -> True)
    ==>
    checkRoundtrip pilSpec1 arg

prop_pilSpec2Roundtrip :: Either [Text] [Text] -> Property
prop_pilSpec2Roundtrip arg =
    (case arg of
       Left [] -> False
       _ -> True)
    ==>
    checkRoundtrip pilSpec2 arg

test_pil11 =
    do x <- parseFromFile (testFile "001.xml") pilSpec1
       assertEqual (Right []) x

test_pil12 =
    do x <- parseFromFile (testFile "001.xml") pilSpec2
       assertEqual (Right []) x

test_pil21 =
    do x <- parseFromFile (testFile "002.xml") pilSpec1
       assertEqual (Left [""]) x

test_pil22 =
    do x <- parseFromFile (testFile "002.xml") pilSpec2
       assertEqual (Left [""]) x

test_pil31 =
    do x <- parseFromFile (testFile "003.xml") pilSpec1
       assertEqual (Right [""]) x

test_pil32 =
    do x <- parseFromFile (testFile "003.xml") pilSpec2
       assertEqual (Right [""]) x

test_deepLookAhead =
    do x <- parseFromFile (testFile "004.xml") spec
       assertEqual (Right "you got it!") x
    where
      spec :: XmlSyntax d => d (Either Text Text)
      spec =
             left <$> xmlElem "a" (xmlElem "b" (xmlElem "c" (xmlElem "d"
                        (xmlElem "e" (xmlElem "f" (xmlElem "h" xmlText))))))
        <||> right <$> xmlElem "a" (xmlElem "b" (xmlElem "c" (xmlElem "d"
                        (xmlElem "e" (xmlElem "f" (xmlElem "g" xmlText))))))

--
-- Utils & main
--

instance Arbitrary Text where
    arbitrary =
        do s <- arbitrary
           return $ T.pack $ trim s
      where
        trim = List.dropWhile isSpace . reverse . List.dropWhile isSpace . reverse

testFile f = "tests" </> f

checkRoundtrip :: (Eq a, Show a) => (forall d . XmlSyntax d => d a) -> a -> Bool
checkRoundtrip spec val =
    case runXmlPrinterString spec val of
      Nothing -> error ("could not print " ++ show val)
      Just t ->
          case runXmlParserString spec "<text>" defaultEntityRenderer t of
            Right val' ->
                if val == val'
                   then True
                   else error (show val ++ " /= " ++ show val')
            Left err -> error ("Parsing of " ++ show t ++ " failed: " ++ show err)

parseFromFileEnum :: (Eq a, Show a)
                  => FilePath -> XmlParseIteratee' IORef IO a-> IO a
parseFromFileEnum fname p =
    do x <- run $ joinI $
                  enumFile fname $$
                  parseBytes decodeEntities $$
                  parseXml_ fname defaultEntityRenderer p
       case x of
         Right y -> return y
         Left ex -> throw ex

parseFromFile :: (Eq a, Show a)
              => FilePath -> (forall d . XmlSyntax d => d a) -> IO a
parseFromFile fname p =
    do bs <- BS.readFile fname
       case runXmlParserByteString p fname defaultEntityRenderer bs of
         Right x ->
             do x' <- parseFromFileEnum fname p
                assertEqualVerbose
                  "mismatch between regular parsing and enumerator-based parsing" x x'
                return x
         Left err -> fail (show err)


main =
    do args <- getArgs
       runTestWithArgs args allHTFTests