HUnitExample.hs

-- |
-- HUnit - Haskell XML Toolbox examples and tests for arrows
--
-- Author: Uwe Schmidt uwe@fh-wedel.de
--

module Main where

import System
import Test.HUnit
import Text.XML.HXT.Arrow
import Text.XML.HXT.XPath


-- |
-- auxiliary function to make haskell string constants with quotes more readable

singleToDoubleQuote	:: String -> String
singleToDoubleQuote
    = map (\ c -> if c == '\'' then '\"' else c)

testLA	:: String -> String -> LA XmlTree XmlTree -> Test
testLA doc expected f
    = TestCase $ assertEqual "LA XmlTree XmlTree:" [expected] res
      where
      res = runLA (xread >>> xshow f) doc

testLAString	:: String -> String -> LA XmlTree String -> Test
testLAString doc expected f
    = TestCase $ assertEqual "LA XmlTree String:" [expected] res
      where
      res = runLA (xread >>> f) doc

mkTestSeqLA	:: String -> [(String, LA XmlTree XmlTree)] -> [Test]
mkTestSeqLA doc
    = map (\ (res, f) -> testLA doc (singleToDoubleQuote res) f)

nodeSetTests	:: Test
nodeSetTests
    = TestList $
      [ TestLabel "node set and simple XPath tests with getXPathTrees" $
	TestList $
	mkTestSeqLA doc (testGetXPathTrees tests)

      , TestLabel "node set and simple XPath tests with getXPathNodeSet" $
	TestList $
	mkTestSeqLA doc (testGetXPathNodes tests)

      , TestLabel "node set and simple XPath tests with processFromNodeSet" $
        TestList $
        mkTestSeqLA doc (testProcessXPath processTests)

      , TestLabel "node set and simple XPath tests with processXPathTrees" $
        TestList $
        mkTestSeqLA doc (testProcessXPath' processTests)
      ]
    where
    doc = "<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0<x p='.3.1'>.3.1.0</x></y>.4</x>"

    testGetXPathTrees = map (\ (r, xp) -> (r, getXPathTrees xp))			-- these arrows are equivalent
    testGetXPathNodes = map (\ (r, xp) -> (r, getFromNodeSet $< getXPathNodeSet xp))	-- except for the ordering of the result set
											-- which does not matter for these tests
    testProcessXPath  = map (\ (r, xp, a) -> (r, processFromNodeSet a $< getXPathNodeSet xp))
    testProcessXPath' = map (\ (r, xp, a) -> (r, processXPathTrees a xp))

    tests = [ (doc						, "/x"	)
	    , ("<y p='.3'>.3.0<x p='.3.1'>.3.1.0</x></y>"	, "/x/y"	)
	    , ("<x p='.3.1'>.3.1.0</x>"				, "/x/y/x"	)
	    , (".0.2.4"						, "/x/text()"	)
	    , (".3.0"						, "/x/y/text()"	)
	    , ("<x p='.1'>.1.0</x><x p='.3.1'>.3.1.0</x>"	, "/x//x"	)
	    ]

    processTests
	 = [ ("<x p='.'>x<x p='.1'>x</x>x<y p='.3'>x<x p='.3.1'>x</x></y>x</x>",	  "//text()",		changeText (const "x")	)
	   , ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0<x p='.3.1'>x</x></y>.4</x>", "/x/y/x/text()",	changeText (const "x")	)
	   , ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0</y>.4</x>", 		  "/x/y/x",		none			)
	   , ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0zzz</y>.4</x>",		  "/x/y/x",		txt "zzz"		)
	   , ("<x p='.'>.0<x p='.1'>.1.0</x>.2<y p='.3'>.3.0<x p='.3.1' q='3.2'>.3.1.0</x></y>.4</x>",
											  "/x/y/x",		addAttr "q" "3.2"	)
	   ]
-- |
-- the complete set of test cases

allTests	:: Test
allTests
    = TestList
      [ nodeSetTests
      ]

main	:: IO ()
main
    = do
      c <- runTestTT allTests
      putStrLn $ show c
      let errs = errors c
	  fails = failures c
      System.exitWith (codeGet errs fails)

codeGet	:: Int -> Int -> ExitCode
codeGet errs fails
    | fails > 0       = ExitFailure 2
    | errs > 0        = ExitFailure 1
    | otherwise       = ExitSuccess

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