-- |
-- Module for running the W3C test cases with the XML parser.
-- The test cases can be found at W3C (<http://www.w3.org/XML/Test/>) Extensible
-- Markup Language (XML) Conformance Test Suites.

-- RunTestCases should be called with a test case description file from the directories:
-- ibm, oasis, sun or xmltest. Perhaps a dummy root node must be added to these files to
-- form a valid XML document. RunTestCases can not process the main file which combines
-- all theses description files.

--
-- Author  : .\\artin Schmidt
-- Version : $Id: RunTestCases.hs,v 1.18 2004/03/22 14:59:15 hxml Exp $

module Main
where

import HdomParser

import System.Directory

import System
    ( ExitCode(..)
    , exitWith
    , getArgs
    )


main :: IO ()
main
    = do
      putStrLn "Test the XMl parser with W3C's XML Conformance Test Suites.\n"
      suite <- getArgs

      if null suite
        then do
	     putStrLn ("RunTestCases should be called with a \"test case description file\" "++
                       "from the directories: ibm, oasis, sun or xmltest.\n\n"++
		       "Perhaps a dummy root node must be added to these files to form "++
		       "a valid XML document.\nRunTestCases can not process the main file "++
		       "which combines all theses description files.")
	     exitWith (ExitFailure (-1))
	else do
	     putStrLn "Which kind of test shall be performed? ([1] - valid | 2 - invalid | 3 - not-wf | 4 - error): "
             kind <- getInt 1

             putStrLn "Show detailed information? (j/[n]) "
             verb <- getBool False

             runTests kind (head suite) verb
	     exitWith ExitSuccess


-- ------------------------------------------------------------
-- Helpers for reading values from stdin, providing a default value

getInt :: Int -> IO Int
getInt defVal
    = do line <- getLine
         checkInput line
      where
      checkInput line
          = if line == ""
	    then return (defVal)
	    else return (read line :: Int)


getBool :: Bool -> IO Bool
getBool defVal
    = do line <- getLine
         checkInput line
      where
      checkInput line
          = if line == ""
            then return (defVal)
	    else if line `elem` ["j","J"]
	         then return (True)
		 else return (False)


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


runTests :: Int -> String -> Bool -> IO ()
runTests kind suite verb
    | kind == 1 = do tests <- getTests suite
		     mapM_ (runOutputTests verb) (isTestKind "valid" $$ tests)

    | kind == 2 = do tests <- getTests suite
                     mapM_ (runBinaryTests invalidTest verb) (isTestKind "invalid" $$ tests)

    | kind == 3 = do tests <- getTests suite
                     mapM_ (runBinaryTests notwellformedTest verb) (isTestKind "not-wf" $$ tests)

    | otherwise = do tests <- getTests suite
                     mapM_ (runBinaryTests errorTest verb) (isTestKind "error" $$ tests)


getTests :: String -> IO [XmlTree]
getTests file
    = do putStrLn "----------------------------------------------------------------"
         putStrLn ("Processing file: "++ file)
         dom <- parseFile file
         return ((multi isTestElement) $$ dom)   -- get TEST nodes from document

isTestKindNode			:: String -> XNode -> Bool
isTestKindNode kind (XTag _ al)	= (lookup1 "TYPE" al) == kind
isTestKindNode _ _		= False

isTestKind			:: String -> XmlFilter
isTestKind kind			= isOfNode (isTestKindNode kind)


isTestElementNode		:: XNode -> Bool
isTestElementNode (XTag n _)	= n == "TEST"
isTestElementNode _		= False

isTestElement			:: XmlFilter
isTestElement 			= isOfNode isTestElementNode


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


-- |
-- Output tests. Test valid documents paired with an output file as the canonical
-- representation of the input file, to ensure that the XML processor provides the
-- correct information.

runOutputTests :: Bool -> XmlTree -> IO ()
runOutputTests verb n@(NTree (XTag _ al)_)
    = do
      currentDir <- getCurrentDirectory  -- necessary so that parser can load further external files (.dtd, .ent)
      setCurrentDirectory dir

      putStrLn "----------------------------------------------------------------"
      putStrLn ("Processing file: "++ filePath ++" | Sections: "++ sections)
      dom <- parseFile file
      setCurrentDirectory currentDir

      ref <- parseFile refFile

      putStrLn (errMsg dom ref)

      return ()
      where
      refFile     = lookup1 "OUTPUT" al
      uri         = lookup1 "URI" al

      dir         = fst $ splitPath uri
      file        = snd $ splitPath uri
      filePath    = dir ++ file

      sections    = lookup1 "SECTIONS" al
      description = "\nDescription:" ++ (showXText $ getChildren n) ++ "\n"

      errMsg :: XmlTrees -> XmlTrees -> String
      errMsg dom ref
        = if null refFile     -- no reference file exists, just check if doc was accepted
	  then if null binTest
	       then "OK - Test passed."
	       else description ++ "\n" ++ binTest ++ "\nERROR - Test failed!"

	  else if null equalTest
	       then "OK - Test passed."
	       else description ++ "\n" ++ equalTest ++ "\nERROR - Test failed!"
	  where
	  binTest
	      = (checkWellformedErrors dom filePath) ++
	        (checkValidationErrors dom)

	  equalTest
	      = (checkWellformedErrors dom filePath) ++
	        (checkWellformedErrors ref refFile) ++
	        (assignEqual
		    (getDocSubset $ canonicalizeAllNodes $$ transform $$ dom)
		    (getDocSubset $ canonicalizeAllNodes $$ ref)
		) ++
	        (checkValidationErrors dom)

      assignEqual :: XmlTrees -> XmlTrees -> String
      assignEqual res orig
          = if (null res) && (null orig)
	    then "Input document tree and reference document tree are empty!\n"
	    else if (res_string /= orig_string)
                 then "Result differs from expected output!\n" ++
                      "Expected was:\n"++
	              orig_string ++ "\n\n" ++
		      (showDetails verb orig) ++
	              "But result was:\n" ++
	              res_string ++ "\n" ++
		      (showDetails verb res)
                 else ""
	    where
	    res_string  = xshow res
	    orig_string = xshow orig


runOutputTests _ n = error ("runOutputTests: illegeal parameter:\n" ++ show n)



-- |
-- Binary conformance tests. Given a document, the parser must reject it (a negative test).
-- It is in that sense that the tests are termed "binary".

runBinaryTests :: (XmlTrees -> String -> String) -> Bool -> XmlTree -> IO ()
runBinaryTests testfct verb n@(NTree (XTag _ al)_)
    = do
      currentDir <- getCurrentDirectory
      setCurrentDirectory dir

      putStrLn "----------------------------------------------------------------"
      putStrLn ("Processing file: "++ filePath ++" | Sections: "++ sections)
      dom <- parseFile file

      putStr (showDetails verb dom)
      putStrLn (description ++ testfct dom filePath)

      setCurrentDirectory currentDir
      where
      uri         = lookup1 "URI" al

      dir         = fst $ splitPath uri
      file        = snd $ splitPath uri
      filePath    = dir ++ file

      sections    = lookup1 "SECTIONS" al
      description = "Description:" ++ (showXText $ getChildren n) ++ "\n"


runBinaryTests _ _ n = error ("runBinaryTests: illegeal parameter:\n" ++ show n)


-- ------------------------------------------------------------
-- Test functions for binary tests

invalidTest :: XmlTrees -> String -> String
invalidTest dom filePath
    = if (not $ null wellformedErrors)
      then "\nERROR / OK - Parser found errors, but validation functions should find errors.\n" ++
           "             Note: Some VC are checked by the parser, so this test might be OK!"
      else if (null validationErrors)
           then "\nERROR - Test failed: Validation functions should find errors!"
           else validationErrors ++ "\nOK - Test passed."
      where
      wellformedErrors = checkWellformedErrors dom filePath
      validationErrors = checkValidationErrors dom


notwellformedTest :: XmlTrees -> String -> String
notwellformedTest dom filePath
    = if (not $ null wellformedErrors)
      then "\nOK - Test passed."
      else if (null validationErrors)
           then "\nERROR - Test failed: Parser did not find well-formed errors!"
           else validationErrors ++ "\n"++
	        "ERROR / OK - Validation functions found errors, but parser should find errors.\n"++
		"             Note: Some WF constraints are checked by the validatation functions, so this test might be OK!"
      where
      wellformedErrors = checkWellformedErrors dom filePath
      validationErrors = checkValidationErrors dom


errorTest :: XmlTrees -> String -> String
errorTest dom filePath
    = if (null wellformedErrors) && (null validationErrors)
      then "\nERROR - Test failed: Parser and validation functions did not find errors!"
      else if not $ null wellformedErrors
           then "\nOK - Test passed."                      -- parser found errors (returned an empty list)
           else validationErrors ++ "\nOK - Test passed."  -- parser returned list, but validation functions found errors
      where
      wellformedErrors = checkWellformedErrors dom filePath
      validationErrors = checkValidationErrors dom


-- ------------------------------------------------------------
-- Helper functions for running tests

splitPath     :: String -> (String, String)
splitPath p    = (getDir, reverse file)
                 where
		 getDir
		     = if dir == ""
		       then "."
		       else reverse dir

                 (file,dir) = break ('/'==) (reverse p)


showDetails :: Bool -> XmlTrees -> String
showDetails verb dom
    = if verb
      then (formatXmlTrees dom ++ "\n")
      else ""
      where
      formatXmlTrees		:: XmlTrees -> String
      formatXmlTrees ts
	  = formatXmlTree $$ root
	    where
	    root = ( addAttr "noOfNodes" show (length ts))
		     .>
		     replaceChildren ts
		   )
		   $ emptyRoot


checkValidationErrors :: XmlTrees -> String
checkValidationErrors dom
    = if null errors
      then ""
      else "\nValidaton errors:\n" ++ showXErrors errors
      where
      errors = validate .> (isError +++ isFatalError) $$ dom


checkWellformedErrors :: XmlTrees -> String -> String
checkWellformedErrors dom file
    = if null dom
      then ("Parser found well-formed errors in file: "++file++"\n")
      else ""


parseFile :: String -> IO [XmlTree]
parseFile filename
    = if null filename
      then return []
      else run' $ getWellformedDoc root
    where
    root = mkEmptyRootTree [(a_source, filename), (a_encoding, utf8)]
	   
getDocSubset :: XmlTrees -> XmlTrees
getDocSubset []  = []
getDocSubset dom = isXTag $$ (getChildren (head dom))