--------------------------------------------------------------------------------
--  $Id: TestXml.hs,v 1.35 2004/07/13 17:32:29 graham Exp $
--
--  Copyright (c) 2004, G. KLYNE.  All rights reserved.
--  See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
--  Module      :  TestXml
--  Copyright   :  (c) 2004, Graham Klyne
--  License     :  LGPL V2
--
--  Maintainer  :  Graham Klyne
--  Stability   :  provisional
--  Portability :  H98
--
--  This module contains test cases for XML parsing and XML handling libraries.
--
--  The test cases make reference to externally stored test data files.
--
--  The module is designed to be retargetable to alternative XML libraries
--  with reasonable effort:  the main body of test cases is isolated from the
--  details of the XML library used.
--
--------------------------------------------------------------------------------

module Main where

import Text.XML.HaXml.Parse
    ( xmlParse'
    )

import Text.XML.HaXml.SubstitutePE
    ( subIntParamEntities
    )

import Text.XML.HaXml.SubstituteGEFilter
    ( subIntGenEntities
    , subExtGenEntities
    )

import Text.XML.HaXml.Validate
    ( validate
    )

import Text.XML.HaXml.Namespace
    ( processNamespaces
    )

import Text.XML.HaXml.XmlBase
    ( processXmlBase
    )

import Text.XML.HaXml.XmlLang
    ( processXmlLang
    )

import Text.XML.HaXml.Lex
    ( xmlLex
    , xmlLexTextDecl
    , xmlLexEntity
    , Posn(..), testPosn
    )

import Text.XML.HaXml.Traverse
    ( docReplaceContent
    , docErrorContent
    , xmlTreeElements
    , xmlListElements
    , xmlListTextContent
    , filterSingle
    , docContent
    )

import Text.XML.HaXml.Pretty
    ( document
    )

import Text.XML.HaXml.QName
    ( makeQN, showQN
    )

import Text.XML.HaXml.Types

import HUnit
    ( Test(TestCase,TestList,TestLabel)
    , Assertable(..)
    , Assertion
    , assertBool, assertEqual, assertString, assertFailure
    , runTestTT, runTestText, putTextToHandle
    )

import IO
    ( Handle, IOMode(WriteMode)
    , openFile, hClose, hPutStr, hPutStrLn
    )

import List
    ( (\\)
    )

------------------------------------------------------------
--  XML handling interfaces
------------------------------------------------------------
--
--  Subsequent tests are based on these interfaces.
--  Re-implement these interfaces to use the XML package
--  under test.
--

doXmlLexOK :: String -> String -> Bool
doXmlLexOK filepath filedata = not $ null (xmlLex filepath filedata)

doXmlPreOK :: String -> String -> Bool
doXmlPreOK filepath filedata = not $ null $
    (subIntParamEntities filepath . xmlLex filepath) filedata

doXmlParseOK :: String -> String -> Bool
doXmlParseOK filepath filedata =
    either (const False) (const True) (xmlParse' filepath filedata)

doXmlParseFormat :: String -> String -> String
doXmlParseFormat filepath filedata =
    either ("Error: "++) (show . document) (xmlParse' filepath filedata)

doXmlParseGESub :: String -> String -> String
doXmlParseGESub filepath filedata =
    either ("Error: "++) (show . document . replaceContent) (xmlParse' filepath filedata)
    where
        replaceContent (Document p s e) = Document p s (docContent (subExtGenEntities s (CElem e)))
        docContent [CElem e] = e
        docContent []        = errElem "produced no output"
        docContent _         = errElem "produced more than one output"
        errElem err          = Elem (makeQN "error") () [] [CErr err]

doXmlParseGESub1 :: String -> String -> String
doXmlParseGESub1 filepath filedata =
    either ("Error: "++) (show . document . replaceContent) (xmlParse' filepath filedata)
    where
        replaceContent (Document p s e) =
            processXmlLang .
            processXmlBase .
            processNamespaces $
            Document p s (docContent (subExtGenEntities s (CElem e)))
        docContent [CElem e] = e
        docContent []        = errElem "produced no output"
        docContent _         = errElem "produced more than one output"
        errElem err          = Elem (makeQN "error") () [] [CErr err]

doXmlValidate :: String -> String -> [String]
doXmlValidate filepath filedata =
    either (return . ("Error: "++))
           (doValidate . replaceContent) (xmlParse' filepath filedata)
    where
        replaceContent (Document p s e) = Document p s (docContent (subExtGenEntities s (CElem e)))
        docContent [CElem e] = e
        docContent []        = errElem "produced no output"
        docContent _         = errElem "produced more than one output"
        errElem err          = Elem (makeQN "error") () [] [CErr err]
        doValidate (Document (Prolog _ _ (Just dtd)) s e) = validate dtd e
        doValidate _ = ["No DTD in document for validation"]

parseGESubDocument :: String -> String -> Document
parseGESubDocument filepath filedata =
    subContent . either docErrorContent id $ (xmlParse' filepath filedata)
    where
        subContent doc@(Document p s e) =
            docReplaceContent (subExtGenEntities s) doc

------------------------------------------------------------
--  Test case helpers
------------------------------------------------------------

testEq :: (Eq a, Show a) => String -> a -> a -> Test
testEq lab a1 a2 =
    TestCase ( assertEqual ("testEq:"++lab) a1 a2 )

assertParseOK :: String -> Bool -> (Either String Document) -> Assertion
assertParseOK lab ok result =
    if ok then assertEqual lab "OK"     (either id              (const "OK") result)
          else assertEqual lab "error"  (either (const "error") (const "OK") result)

assertValid :: String -> Bool -> [String] -> Assertion
assertValid lab ok [] =
    assertEqual lab (if ok then [] else ["error"]) []
assertValid lab ok result =
    assertEqual lab (if ok then [] else result) result

------------------------------------------------------------
--  XML test case functions
------------------------------------------------------------

testXmlLexOK :: String -> Bool -> String -> Test
testXmlLexOK lab ok filepath = TestCase $
    do  { -- putStrLn ("\nTest "++lab)
        ; s <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; assertEqual lab ok (doXmlLexOK filepath s)
        }

testXmlPreOK :: String -> Bool -> String -> Test
testXmlPreOK lab ok filepath = TestCase $
    do  { -- putStrLn ("\nTest "++lab)
        ; s <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; assertEqual lab ok (doXmlPreOK filepath s)
        }

testXmlParseOK :: String -> Bool -> String -> Test
testXmlParseOK lab ok filepath = TestCase $
    do  { -- putStrLn ("\nTest "++lab)
        ; s <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; assertParseOK lab ok (xmlParse' filepath s)
        }

testXmlFormat :: String -> String -> String -> Test
testXmlFormat lab filepathI filepathF = TestCase $
    do  { si <- readFile filepathI
        -- ; writeFile (filepathF++".tmp") (doXmlParseFormat filepathI si)
        ; sf <- readFile filepathF
        ; assertEqual lab sf (doXmlParseFormat filepathI si)
        }

--  Test substitution of General Entities
testXmlGESub :: String -> String -> String -> Test
testXmlGESub lab filepathI filepathF = TestCase $
    do  { si <- readFile filepathI
        -- ; writeFile (filepathF++".tmp") (doXmlParseGESub filepathI si)
        ; sf <- readFile filepathF
        ; assertEqual lab sf (doXmlParseGESub filepathI si)
        }

--  Test substitution of General Entities
testXmlGESub1 :: String -> String -> String -> Test
testXmlGESub1 lab filepathI filepathF = TestCase $
    do  { si <- readFile filepathI
        -- ; writeFile (filepathF++".tmp") (doXmlParseGESub1 filepathI si)
        ; sf <- readFile filepathF
        ; assertEqual lab sf (doXmlParseGESub1 filepathI si)
        }

--  Test validation following substitution of General Entities
testXmlValid :: String -> Bool -> String -> Test
testXmlValid lab ok filepathI = TestCase $
    do  { si <- readFile filepathI
        -- ; writeFile (filepathF++".tmp") (doXmlValidate filepathI si)
        ; assertValid lab ok (doXmlValidate filepathI si)
        }

--  Test namespace handling.  This test works by namespace-processing a file,
--  building a list of QNames correspondingto the elements and attributes
--  within the file, and comparing that list with a supplied value.

testXmlQNames :: String -> String -> [QName] -> Test
testXmlQNames lab filepathI qns = TestCase $
    do  { si <- readFile filepathI
        ; let doc    = parseGESubDocument filepathI si
        ; let docns  = processNamespaces doc
        ; let docqns = concatMap elemQNs (xmlListElements docns)
        ; assertEqual lab qns docqns
        }
    where
        elemQNs (CElem (Elem en _ ats _)) = en:(map attrQN ats)
        elemQNs _                         = []
        attrQN  (an,_)                    = an

egns, egns1, egns2 :: Namespace
egns  = NS "eg" "http://id.example.org/namespace"
egns1 = NS "eg" "http://id.example.org/ns1"
egns2 = NS "eg" "http://id.example.org/ns2"

mknsQN :: Namespace -> String -> QName
mknsQN ns ln = QN ln (Just ns)


--  Test XML base.  This works like the namespace test
--  (to confirm xml:base attributes are removed), but also
--  includes the xml:base QName for each element in the
--  resulting list.

testXmlBase :: String -> String -> [QName] -> Test
testXmlBase lab filepathI qns = TestCase $
    do  { si <- readFile filepathI
        ; let doc    = parseGESubDocument filepathI si
        ; let docns  = processNamespaces doc
        ; let docbas = processXmlBase docns
        ; let docqns = concatMap elemQNs (xmlListElements docbas)
        ; assertEqual lab qns docqns
        }
    where
        elemQNs (CElem (Elem en ei ats _)) = en:baseQN ei:(map attrQN ats)
        elemQNs _                          = []
        baseQN                             = makeQN . eiBase
        attrQN  (an,_)                     = an

egbas = NS "egbas" "http://id.example.org/"

--  Test XML language.  This works like the namespace test
--  (to confirm xml:base attributes are removed), but also
--  includes an xml:lang-basedQName for each element in the
--  resulting list.

testXmlLang :: String -> String -> [QName] -> Test
testXmlLang lab filepathI qns = TestCase $
    do  { si <- readFile filepathI
        ; let doc    = parseGESubDocument filepathI si
        ; let docns  = processNamespaces doc
        ; let docbas = processXmlBase docns
        ; let doclng = processXmlLang docbas
        ; let docqns = concatMap elemQNs (xmlListElements doclng)
        ; assertEqual lab qns docqns
        }
    where
        elemQNs (CElem (Elem en ei ats _)) = en:baseQN ei:langQN ei
                                             :(map attrQN ats)
        elemQNs _                          = []
        baseQN                             = makeQN . eiBase
        langQN                             = makeQN . eiLang
        attrQN  (an,_)                     = an

--  Test attribute values.
--  Read, parse and namespace-process an XML file,
--  then list all attribute values, checking that each attribute
--  is a single string value.
testAttributes :: String -> String -> [String] -> Test
testAttributes lab filepathI qns = TestCase $
    do  { si <- readFile filepathI
        ; let doc    = parseGESubDocument filepathI si
        ; let docns  = processNamespaces doc
        ; let docqns = concatMap elemAttrs (xmlListElements docns)
        ; assertEqual lab qns docqns
        }
    where
        elemAttrs (CElem (Elem en ei ats _)) = (map attrVal ats)
        elemAttrs _                          = []
        attrVal (_,AttValue [Left av])       = av
        attrVal (_,av)                       = "Bad attr: "++show av

--  Test free-text content
--  Read, parse and namespace-process an XML file,
--  then list all free-text values
testFreetext :: String -> String -> [String] -> Test
testFreetext lab filepathI qns = TestCase $
    do  { si <- readFile filepathI
        ; let doc    = parseGESubDocument filepathI si
        ; let docns  = processNamespaces doc
        ; let docqns = map elemText (xmlListTextContent docns)
        ; assertEqual lab qns docqns
        }
    where
        elemText (CString _ txt) = txt
        elemText (CRef (RefEntity ref)) = "&"++ref++";"
        elemText (CRef (RefChar code))  = "&#"++show code++";"

--  Construct test suites from file and list of suffixes
makeTestXmlParseOK :: String -> Bool -> String -> [String] -> Test
makeTestXmlParseOK lab ok fileroot suffixes =
    TestList [ testXmlParseOK (lab++s) ok (fileroot++s++".xml") | s <- suffixes ]

makeTestXmlValidOK :: String -> Bool -> String -> [String] -> Test
makeTestXmlValidOK lab ok fileroot suffixes =
    TestList [ testXmlValid (lab++s) ok (fileroot++s++".xml") | s <- suffixes ]

------------------------------------------------------------
--  Basic XML parsing tests
------------------------------------------------------------

testXmlLex01 = testXmlLexOK "TestXmlLex01" True  "9x9/xmlData01I.xml"
testXmlLex06 = testXmlPreOK "TestXmlLex06" True  "9x9/xmlData06I.xml"
testXmlLex07 = testXmlPreOK "TestXmlLex07" True  "9x9/xmlData07I.xml"
testXmlLex22 = testXmlPreOK "TestXmlLex22" True  "9x9/xmlData22I.xml"

testXmlParse01 = testXmlParseOK "TestXmlParse01" True  "9x9/xmlData01I.xml"
testXmlParse02 = testXmlParseOK "TestXmlParse02" True  "9x9/xmlData02I.xml"
testXmlParse03 = testXmlParseOK "TestXmlParse03" False "9x9/xmlData03I.xml"
testXmlParse04 = testXmlParseOK "TestXmlParse04" False "9x9/xmlData04I.xml"
testXmlParse05 = testXmlParseOK "TestXmlParse05" False "9x9/xmlData05I.xml"
testXmlParse06 = testXmlParseOK "TestXmlParse06" False "9x9/xmlData06I.xml"
testXmlParse07 = testXmlParseOK "TestXmlParse07" True  "9x9/xmlData07I.xml"
testXmlParse08 = testXmlParseOK "TestXmlParse08" True  "9x9/xmlData08I.xml"
testXmlParse09 = testXmlParseOK "TestXmlParse09" False "9x9/xmlData09I.xml"

--  Internal subset tests
testXmlParse20 = testXmlParseOK "TestXmlParse20" True  "9x9/KAoSOntologiesI.owl"
testXmlParse21 = testXmlParseOK "TestXmlParse21" True  "9x9/xmlData21I.xml"
testXmlParse22 = testXmlParseOK "TestXmlParse22" True  "9x9/xmlData22I.xml"
testXmlParse23 = testXmlParseOK "TestXmlParse23" True  "9x9/xmlData23I.xml"
testXmlParse24 = testXmlParseOK "TestXmlParse24" True  "9x9/xmlData24I.xml"
testXmlParse25 = testXmlParseOK "TestXmlParse25" True  "9x9/xmlData25I.xml"
testXmlParse26 = testXmlParseOK "TestXmlParse26" True  "9x9/xmlData26I.xml"
testXmlParse27 = testXmlParseOK "TestXmlParse27" True  "9x9/xmlData27I.xml"
testXmlParse28 = testXmlParseOK "TestXmlParse28" True  "9x9/xmlData28I.xml"
testXmlParse29 = testXmlParseOK "TestXmlParse29" True  "9x9/xmlData29I.xml"

--  External subset tests
testXmlParse31 = testXmlParseOK "TestXmlParse31" True  "9x9/xmlconf_xmltest_097I.xml"
-- This test requires Internet/HTTP access:
test32uri = "http://dev.w3.org/cvsweb/~checkout~/2001/XML-Test-Suite/xmlconf/xmltest/valid/sa/097.ent?rev=1.1&content-type=text/plain"
testXmlParse32 = testXmlParseOK "TestXmlParse32" True  "9x9/xmlData32I.xml"
--
testXmlParse33 = testXmlParseOK "TestXmlParse33" True  "9x9/xmlData33I.xml"

--  Check namespace tests parse OK
testXmlParse41 = testXmlParseOK "TestXmlParse41" True  "9x9/xmlNamespace01.xml"
testXmlParse42 = testXmlParseOK "TestXmlParse42" True  "9x9/xmlNamespace02.xml"
testXmlParse43 = testXmlParseOK "TestXmlParse43" True  "9x9/xmlNamespace03.xml"
testXmlParse44 = testXmlParseOK "TestXmlParse44" True  "9x9/xmlNamespace04.xml"
testXmlParse45 = testXmlParseOK "TestXmlParse45" True  "9x9/xmlNamespace05.xml"
testXmlParse46 = testXmlParseOK "TestXmlParse46" True  "9x9/xmlNamespace06.xml"
testXmlParse47 = testXmlParseOK "TestXmlParse47" True  "9x9/xmlNamespace07.xml"
testXmlParse48 = testXmlParseOK "TestXmlParse48" True  "9x9/xmlNamespace08.xml"
testXmlParse49 = testXmlParseOK "TestXmlParse49" True  "9x9/xmlNamespace09.xml"
testXmlParse50 = testXmlParseOK "TestXmlParse50" True  "9x9/simple.rdf"

testXmlFormat01 = testXmlFormat "TestXmlFormat01" "9x9/xmlData01I.xml"           "9x9/xmlData01F.xml"
testXmlFormat02 = testXmlFormat "TestXmlFormat02" "9x9/xmlData02I.xml"           "9x9/xmlData02F.xml"
testXmlFormat03 = testXmlFormat "TestXmlFormat03" "9x9/xmlData03I.xml"           "9x9/xmlData03F.xml"
testXmlFormat04 = testXmlFormat "TestXmlFormat04" "9x9/xmlData04I.xml"           "9x9/xmlData04F.xml"
testXmlFormat05 = testXmlFormat "TestXmlFormat05" "9x9/xmlData05I.xml"           "9x9/xmlData05F.xml"
testXmlFormat06 = testXmlFormat "TestXmlFormat06" "9x9/xmlData06I.xml"           "9x9/xmlData06F.xml"
testXmlFormat07 = testXmlFormat "TestXmlFormat07" "9x9/xmlData07I.xml"           "9x9/xmlData07F.xml"
testXmlFormat08 = testXmlFormat "TestXmlFormat08" "9x9/xmlData08I.xml"           "9x9/xmlData08F.xml"
testXmlFormat09 = testXmlFormat "TestXmlFormat09" "9x9/xmlData09I.xml"           "9x9/xmlData09F.xml"

--  Internal subset tests
testXmlFormat20 = testXmlFormat "TestXmlFormat20" "9x9/KAoSOntologiesI.owl"      "9x9/KAoSOntologiesF.owl"
testXmlFormat21 = testXmlFormat "TestXmlFormat21" "9x9/xmlData21I.xml"           "9x9/xmlData21F.xml"
testXmlFormat22 = testXmlGESub  "TestXmlFormat22" "9x9/xmlData22I.xml"           "9x9/xmlData22F.xml"
testXmlFormat23 = testXmlGESub  "TestXmlFormat23" "9x9/xmlData23I.xml"           "9x9/xmlData23F.xml"
testXmlFormat24 = testXmlGESub  "TestXmlFormat24" "9x9/xmlData24I.xml"           "9x9/xmlData24F.xml"
testXmlFormat25 = testXmlGESub  "TestXmlFormat25" "9x9/xmlData25I.xml"           "9x9/xmlData25F.xml"
testXmlFormat26 = testXmlGESub  "TestXmlFormat26" "9x9/xmlData26I.xml"           "9x9/xmlData26F.xml"
testXmlFormat27 = testXmlGESub  "TestXmlFormat27" "9x9/xmlData27I.xml"           "9x9/xmlData27F.xml"
testXmlFormat28 = testXmlGESub  "TestXmlFormat28" "9x9/xmlData28I.xml"           "9x9/xmlData28F.xml"
testXmlFormat29 = testXmlGESub  "TestXmlFormat29" "9x9/xmlData29I.xml"           "9x9/xmlData29F.xml"

--  External subset tests
testXmlFormat31 = testXmlFormat "TestXmlFormat31" "9x9/xmlconf_xmltest_097I.xml" "9x9/xmlconf_xmltest_097F.xml"
testXmlFormat32 = testXmlFormat "TestXmlFormat32" "9x9/xmlData32I.xml"           "9x9/xmlData32F.xml"
testXmlFormat33 = testXmlGESub  "TestXmlFormat33" "9x9/xmlData33I.xml"           "9x9/xmlData33F.xml"

--  Namespace tests
testXmlFormat41 = testXmlGESub  "TestXmlFormat41" "9x9/xmlNamespace01.xml"       "9x9/xmlNamespace01F.xml"
testXmlFormat42 = testXmlGESub  "TestXmlFormat42" "9x9/xmlNamespace02.xml"       "9x9/xmlNamespace02F.xml"
testXmlFormat43 = testXmlGESub  "TestXmlFormat43" "9x9/xmlNamespace03.xml"       "9x9/xmlNamespace03F.xml"
testXmlFormat44 = testXmlGESub  "TestXmlFormat44" "9x9/xmlNamespace04.xml"       "9x9/xmlNamespace04F.xml"
testXmlFormat45 = testXmlGESub  "TestXmlFormat45" "9x9/xmlNamespace05.xml"       "9x9/xmlNamespace05F.xml"
testXmlFormat46 = testXmlGESub  "TestXmlFormat46" "9x9/xmlNamespace06.xml"       "9x9/xmlNamespace06F.xml"
testXmlFormat47 = testXmlGESub  "TestXmlFormat47" "9x9/xmlNamespace07.xml"       "9x9/xmlNamespace07F.xml"
testXmlFormat48 = testXmlGESub  "TestXmlFormat48" "9x9/xmlNamespace08.xml"       "9x9/xmlNamespace08F.xml"
testXmlFormat49 = testXmlGESub  "TestXmlFormat49" "9x9/xmlNamespace09.xml"       "9x9/xmlNamespace09F.xml"

testXmlFormat50 = testXmlGESub  "testXmlFormat50" "9x9/simple.rdf"               "9x9/simpleF.rdf"
testXmlFormat51 = testXmlGESub1 "testXmlFormat51" "9x9/XmlBase01.xml"            "9x9/XmlBase01F.xml"
testXmlFormat52 = testXmlGESub1 "testXmlFormat52" "9x9/XmlBase02.xml"            "9x9/XmlBase02F.xml"
testXmlFormat53 = testXmlGESub1 "testXmlFormat53" "9x9/XmlBase03.xml"            "9x9/XmlBase03F.xml"
testXmlFormat54 = testXmlGESub1 "testXmlFormat54" "9x9/XmlBase04.xml"            "9x9/XmlBase04F.xml"

testXmlFormat61 = testXmlGESub1 "testXmlFormat61" "9x9/XmlLang01.xml"            "9x9/XmlLang01F.xml"
testXmlFormat62 = testXmlGESub1 "testXmlFormat62" "9x9/XmlLang02.xml"            "9x9/XmlLang02F.xml"
testXmlFormat63 = testXmlGESub1 "testXmlFormat63" "9x9/XmlLang03.xml"            "9x9/XmlLang03F.xml"
testXmlFormat64 = testXmlGESub1 "testXmlFormat64" "9x9/XmlLang04.xml"            "9x9/XmlLang04F.xml"

--  Validation tests
testXmlValid07 = testXmlValid "testXmlValid07" True  "9x9/xmlData07I.xml"
testXmlValid21 = testXmlValid "testXmlValid21" True  "9x9/xmlData21I.xml"
testXmlValid22 = testXmlValid "testXmlValid22" False "9x9/xmlData22I.xml"
testXmlValid23 = testXmlValid "testXmlValid23" False "9x9/xmlData23I.xml"
testXmlValid24 = testXmlValid "testXmlValid24" False "9x9/xmlData24I.xml"
testXmlValid25 = testXmlValid "testXmlValid25" True  "9x9/xmlData25I.xml"
testXmlValid26 = testXmlValid "testXmlValid26" False "9x9/xmlData26I.xml"
testXmlValid27 = testXmlValid "testXmlValid27" False "9x9/xmlData27I.xml"
testXmlValid28 = testXmlValid "testXmlValid28" True  "9x9/xmlData28I.xml"
testXmlValid29 = testXmlValid "testXmlValid29" True  "9x9/xmlData29I.xml"

--  Namespace tests
testXmlNamespace01 = testXmlQNames "testXmlNamespace01" "9x9/xmlNamespace01.xml"
    [ mknsQN egns "doc" ]
testXmlNamespace02 = testXmlQNames "testXmlNamespace02" "9x9/xmlNamespace02.xml"
    [ makeQN "doc", mknsQN egns "a1" ]
testXmlNamespace03 = testXmlQNames "testXmlNamespace03" "9x9/xmlNamespace03.xml"
    [ makeQN "doc"
    , mknsQN egns "inner", mknsQN egns "a2"
    , mknsQN egns "deeper", mknsQN egns "a3"
    ]
testXmlNamespace04 = testXmlQNames "testXmlNamespace04" "9x9/xmlNamespace04.xml"
    [ mknsQN egns "doc"
    , mknsQN egns "inner", makeQN "a2"
    , mknsQN egns "deeper", makeQN "a3"
    ]
testXmlNamespace05 = testXmlQNames "testXmlNamespace05" "9x9/xmlNamespace05.xml"
    [ mknsQN egns "doc"
    , mknsQN egns "inner", mknsQN egns "a2"
    , mknsQN egns "deeper", mknsQN egns "a3"
    ]
testXmlNamespace06 = testXmlQNames "testXmlNamespace06" "9x9/xmlNamespace06.xml"
    [ mknsQN egns "doc"
    , mknsQN egns "inner", mknsQN egns "a2"
    , mknsQN egns "deeper", mknsQN egns "a3"
    ]
testXmlNamespace07 = testXmlQNames "testXmlNamespace07" "9x9/xmlNamespace07.xml"
    [ mknsQN egns "doc"
    , mknsQN egns "inner", mknsQN egns "a2"
    , mknsQN egns "deeper", mknsQN egns "a3"
    ]
testXmlNamespace08 = testXmlQNames "testXmlNamespace08" "9x9/xmlNamespace08.xml"
    [ mknsQN egns "doc"
    , mknsQN egns1 "inner", mknsQN egns1 "a2"
    , mknsQN egns2 "deeper", mknsQN egns2 "a3"
    ]
testXmlNamespace09 = testXmlQNames "testXmlNamespace09" "9x9/xmlNamespace09.xml"
    [ mknsQN egns "doc"
    , mknsQN egns1 "inner", mknsQN egns1 "a2"
    ]

--  xml:base tests
testXmlBase01 = testXmlBase "testXmlBase01" "9x9/XmlBase01.xml"
    [ makeQN "doc",         makeQN "9x9/XmlBase01.xml"
    , mknsQN egns "inner",  makeQN "9x9/XmlBase01.xml", mknsQN egns "a2"
    , mknsQN egns "deeper", makeQN "9x9/XmlBase01.xml", mknsQN egns "a3"
    ]
testXmlBase02 = testXmlBase "testXmlBase02" "9x9/XmlBase02.xml"
    [ makeQN "doc",         mknsQN  egbas "base1"
    , mknsQN egns "inner",  mknsQN  egbas "base1", mknsQN egns "a2"
    , mknsQN egns "deeper", mknsQN  egbas "base1", mknsQN egns "a3"
    ]
testXmlBase03 = testXmlBase "testXmlBase03" "9x9/XmlBase03.xml"
    [ makeQN "doc",             makeQN "9x9/XmlBase03.xml"
    , mknsQN egns "inner",      mknsQN  egbas "base1", mknsQN egns "a2"
    , mknsQN egns "deeper",     mknsQN  egbas "base2", mknsQN egns "a3"
    , mknsQN egns "evendeeper", mknsQN  egbas "base2"
    ]
testXmlBase04 = testXmlBase "testXmlBase04" "9x9/XmlBase04.xml"
    [ makeQN "doc",                makeQN "9x9/XmlBase04.xml"
    , mknsQN egns "inner",         mknsQN  egbas "base1", mknsQN egns "a2"
    , mknsQN egns "deeper",        mknsQN  egbas "base2", mknsQN egns "a3"
    , mknsQN egns "evendeeper",    mknsQN  egbas "base2"
    , mknsQN egns "anotherdeeper", mknsQN  egbas "base1"
    ]

--  xml:lang tests
testXmlLang01 = testXmlLang "testXmlLang01" "9x9/XmlLang01.xml"
    [ makeQN "doc",         makeQN "9x9/XmlLang01.xml", makeQN ""
    , mknsQN egns "inner",  makeQN "9x9/XmlLang01.xml", makeQN ""
      , mknsQN egns "a2"
    , mknsQN egns "deeper", makeQN "9x9/XmlLang01.xml", makeQN ""
      , mknsQN egns "a3"
    ]
testXmlLang02 = testXmlLang "testXmlLang02" "9x9/XmlLang02.xml"
    [ makeQN "doc",         mknsQN  egbas "base1", makeQN "en"
    , mknsQN egns "inner",  mknsQN  egbas "base1", makeQN "en"
      , mknsQN egns "a2"
    , mknsQN egns "deeper", mknsQN  egbas "base1", makeQN "en"
      , mknsQN egns "a3"
    ]
testXmlLang03 = testXmlLang "testXmlLang03" "9x9/XmlLang03.xml"
    [ makeQN "doc",             makeQN "9x9/XmlLang03.xml", makeQN ""
    , mknsQN egns "inner",      mknsQN  egbas "base1",  makeQN "fr"
      , mknsQN egns "a2"
    , mknsQN egns "deeper",     mknsQN  egbas "base2",  makeQN "de"
      , mknsQN egns "a3"
    , mknsQN egns "evendeeper", mknsQN  egbas "base2",  makeQN "de"
    ]
testXmlLang04 = testXmlLang "testXmlLang04" "9x9/XmlLang04.xml"
    [ makeQN "doc",                makeQN "9x9/XmlLang04.xml", makeQN ""
    , mknsQN egns "inner",         mknsQN egbas "base1",   makeQN "fr"
      , mknsQN egns "a2"
    , mknsQN egns "deeper",        mknsQN egbas "base2",   makeQN "de"
      , mknsQN egns "a3"
    , mknsQN egns "evendeeper",    mknsQN egbas "base2",   makeQN "de"
    , mknsQN egns "anotherdeeper", mknsQN egbas "base1",   makeQN "fr"
    , mknsQN egns "evendeeper",    makeQN "",              makeQN ""
    ]

--  Attribute-value tests
testXmlAttributes01 = testAttributes "testXmlAttributes01" "9x9/SchemaPart.rdf"
    [ "Resource"
    , "en"
    , "fr"
    , "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
    , "en"
    , "fr"
    , "#Class"
    , "subPropertyOf"
    , "en"
    , "fr"
    , "http://www.w3.org/1999/02/22-rdf-syntax-ns#Property"
    , "http://www.w3.org/1999/02/22-rdf-syntax-ns#Property"
    ]

--  Text-content-value tests
testXmlFreetext01 = testFreetext "testXmlFreetext01" "9x9/SchemaPart.rdf"
    [ "Resource"
    , "Ressource"
    , "The most general class"
    , "type"
    , "type"
    , "Indicates membership of a class"
    , "subPropertyOf"
    , "sousPropri\233\&t\233\&De"
    , "Indicates specialization of properties"
    ]


--  Complete test suite
testXmlParseSuite = TestList
    [ testXmlLex01
    , testXmlLex06
    , testXmlLex07
    , testXmlLex22
    , testXmlParse01
    , testXmlParse02
    , testXmlParse03
    , testXmlParse04
    , testXmlParse05
    , testXmlParse06
    , testXmlParse07
    , testXmlParse08
    , testXmlParse09
    , testXmlParse20
    , testXmlParse21
    , testXmlParse22
    , testXmlParse23
    , testXmlParse24
    , testXmlParse25
    , testXmlParse26
    , testXmlParse27
    , testXmlParse28
    , testXmlParse29
    , testXmlParse31
    -- , testXmlParse32 -- requires internet access, see below
    , testXmlParse33
    , testXmlParse41
    , testXmlParse42
    , testXmlParse43
    , testXmlParse44
    , testXmlParse45
    , testXmlParse46
    , testXmlParse47
    , testXmlParse48
    , testXmlParse49
    , testXmlParse50
    , testXmlFormat01
    , testXmlFormat02
    , testXmlFormat03
    , testXmlFormat04
    , testXmlFormat05
    , testXmlFormat06
    , testXmlFormat07
    , testXmlFormat08
    , testXmlFormat09
    , testXmlFormat20
    , testXmlFormat21
    , testXmlFormat22
    , testXmlFormat23
    , testXmlFormat24
    , testXmlFormat25
    , testXmlFormat26
    , testXmlFormat27
    , testXmlFormat28
    , testXmlFormat29
    , testXmlFormat31
    -- , testXmlFormat32 -- requires internet access, see below
    , testXmlFormat33
    , testXmlFormat41
    , testXmlFormat42
    , testXmlFormat43
    , testXmlFormat44
    , testXmlFormat45
    , testXmlFormat46
    , testXmlFormat47
    , testXmlFormat48
    , testXmlFormat49
    , testXmlFormat50
    , testXmlFormat51
    , testXmlFormat52
    , testXmlFormat53
    , testXmlFormat54
    , testXmlFormat61
    , testXmlFormat62
    , testXmlFormat63
    , testXmlFormat64
    , testXmlValid07
    , testXmlValid21
    , testXmlValid22
    , testXmlValid23
    , testXmlValid24
    , testXmlValid25
    , testXmlValid26
    , testXmlValid27
    , testXmlValid28
    , testXmlValid29
    , testXmlNamespace01
    , testXmlNamespace02
    , testXmlNamespace03
    , testXmlNamespace04
    , testXmlNamespace05
    , testXmlNamespace06
    , testXmlNamespace07
    , testXmlNamespace08
    , testXmlNamespace09
    , testXmlBase01
    , testXmlBase02
    , testXmlBase03
    , testXmlBase04
    , testXmlLang01
    , testXmlLang02
    , testXmlLang03
    , testXmlLang04
    , testXmlAttributes01
    , testXmlFreetext01
    ]

testXmlHTTPSuite = TestList
    [ testXmlParse32    -- HTTP access test
    , testXmlFormat32   -- HTTP access test
    ]

--  The following tests are designed to work with files from the
--  W3C XML test suite, which can be obtained from:
--    http://www.w3.org/XML/Test/
--  Retrieve the test suite archive and unpack the directory structure
--  into a directory from which the test program is run (I use the source
--  code directory:  the archive has all its content in subdirectories).
--
--  The tests are generated from the 3-digit number that is used to form
--  the test suite filename in each case, with tests known not to work being
--  removed from the list.  I expect these omissions to be removed as the
--  parser is refined.
--
--  Note:  at this time, the "Valid" XML test suite is used only for testing
--  well-formedness chacks by the parser.  Additional tests may perform validity
--  checking.

jamesClarkParseSASuite =
    makeTestXmlParseOK "JamesClarkParseWFSA" True "xml-conformance/xmltest/valid/sa/"
        ( map (showNDigits 3) [1..119]
        )

jamesClarkNotWfSASuite =
    makeTestXmlParseOK "jamesClarkNotWfSA" False "xml-conformance/xmltest/not-wf/sa/"
        ( map (showNDigits 3) [1..186] \\
          ["006"                                                -- comment containing '--'
          ,"014"                                                -- Literal '<' in attribute value
          ,"025","026","029"                                    -- content containing ']]>'
          ,"038"                                                -- duplicate attr name (is XML WFC)
          ,"061","062","064","065","066","067","068","069"      -- Missing spaces in DTD
          ,"070"                                                -- <!-- ... --->
          ,"071","075","079","080"                              -- Mutually recursive entities
          ,"072","073","076","077","078"                        -- Entity not declared
          ,"074"                                                -- Entity closes containing element
          ,"081","082"                                          -- Attribute ref external entity
          ,"083","084"                                          -- Entity reference unparsed entity
          ,"090"                                                -- Char ref makes ill-formed content
          ,"092"                                                -- Char ref makes ill-formed attribute
          ,"096"                                                -- Missing space in ?XML PI
          ,"101"                                                -- encoding name format
          ,"102"                                                -- version number format
          ,"103"                                                -- Char ref in entity makes ill-formed
          ,"113"                                                -- Unused PE has ill-formed content
          ,"115","116","117","119","120"                        -- Char ref makes ill-formed ent value
          ,"133","134"                                          -- Extra spaces between tokens
          ,"137"                                                -- Missing space
          ,"140","141"                                          -- Char ref makes bad element name
          ,"147"                                                -- Whitespace before <?xml ... ?>
          ,"153"                                                -- Entity gives invalid <?xml ... ?>
          ,"160","161"                                          -- Violates use of PE in internal subset
          ,"162"                                                -- Unused indirect PE has bad content
          ,"165"                                                -- Missing space before %
          ,"180"        -- Entity used before declaration: fix when processing entities
          ,"181","182"  -- Entity value not "content" production: fix when processing entities
          ,"185"        -- External entity in standalone document: fix when processing entities
          ,"186"                                                -- Missing whitespace between attrs
          ]
        )

jamesClarkValidSASuite =
    makeTestXmlValidOK "JamesClarkValidSA" True "xml-conformance/xmltest/valid/sa/"
        ( map (showNDigits 3) [1..119]
        )

showNDigits :: Int -> Int -> String
showNDigits places val = pad places (show val)
    where
        pad places str = replicate (places-length str) '0' ++ str

------------------------------------------------------------
--  All tests
------------------------------------------------------------

allTests = TestList
    [ testXmlParseSuite
    -- , testXmlHTTPSuite          -- requires Internet/HTTP access
    , jamesClarkParseSASuite
    , jamesClarkNotWfSASuite
    , jamesClarkValidSASuite
    ]


main = runTestTT allTests

nwf = runTestTT  jamesClarkNotWfSASuite

check = runTestTT testXmlParseSuite

testValid s = makeTestXmlParseOK "JamesClarkValidSA" True "xml-conformance/xmltest/valid/sa/" [s]

runTestFile t = do
    h <- openFile "a.tmp" WriteMode
    runTestText (putTextToHandle h False) t
    hClose h
tf = runTestFile
tt = runTestTT

xmlLexData :: String -> IO String
xmlLexData filepath =
    do  { s <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; let l = xmlLex filepath s
        ; let r = show (length l) ++ "\n**\n" ++ concatMap ((++"\n") . show) l ++ "\n**\n"
        ; putStrLn r
        ; return r
        }

xmlEntData :: String -> IO String
xmlEntData filepath =
    do  { s <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; let l = xmlLexTextDecl filepath Nothing s
        ; let r = show (length l) ++ "\n**\n" ++ concatMap ((++"\n") . show) l ++ "\n**\n"
        ; putStrLn r
        ; return r
        }

xmlPreData :: String -> String -> IO String
xmlPreData p f =
    do  { let filepath = p++f
        ; filedata <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; let l = (subIntParamEntities filepath . xmlLex filepath) filedata
        ; let r = show (length l) ++ "\n**\n" ++ concatMap ((++"\n") . show) l ++ "\n**\n"
        ; putStrLn r
        ; return r
        }

xmlSymData :: String -> String -> IO String
xmlSymData p f =
    do  { let filepath = p++f
        ; filedata <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; let p = (xmlParse' filepath filedata)
        ; let r = case p of
                (Left  err) -> ("Error: "++err)
                (Right (Document pro sym root)) ->
                    show (length sym) ++ "\n**\n" ++ concatMap ((++"\n") . showste) sym ++ "\n**\n"
        ; putStrLn r
        ; return r
        }
    where
        showste (nam,entdef) = nam++": "++showent entdef++"\n"
        showent (DefEntityValue (EntityValue evs)) = concatMap (("\n  "++) . showev) evs
        showent (DefExternalID bas eid _ )         = ("\n  External base="++bas++", eid="++showeid eid)
        showeid (SYSTEM   (SystemLiteral uri))     = uri
        showeid (PUBLIC _ (SystemLiteral uri))     = uri
        showev  (EVString str)                     = str
        showev  (EVRef (RefEntity nam))            = "&"++nam++";"
        showev  (EVRef (RefChar code))             = "&#"++show code++";"

xmlDocData :: String -> String -> IO String
xmlDocData p f =
    do  { let filepath = p++f
        ; filedata <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; let p = (xmlParse' filepath filedata)
        ; let r = case p of
                (Left  err) -> ("Error: "++err)
                (Right doc) -> (show . document) doc
        ; putStrLn r
        ; return r
        }

xmlSubData :: String -> String -> IO String
xmlSubData p f =
    do  { let filepath = p++f
        ; filedata <- catch (readFile filepath)  (error ("Failed reading file "++filepath))
        ; let p = (xmlParse' filepath filedata)
        ; let r = case p of
                (Left  err) -> ("Error: "++err)
                (Right doc) -> (show . document) (subContent doc)
        ; putStrLn r
        ; return r
        }
    where
        subContent doc@(Document _ s _) =
            docReplaceContent (subExtGenEntities s) doc


validPath = "xml-conformance/xmltest/valid/sa/"
notwfPath = "xml-conformance/xmltest/not-wf/sa/"
localPath = ""

entdata = xmlEntData "9x9/xmlconf_xmltest_097.ent"
lexdata = xmlLexData "9x9/xmlData26I.xml"
predata = xmlPreData localPath "9x9/xmlNamespace05.xml"
symdata = xmlSymData localPath "9x9/xmlNamespace05.xml"
docdata = xmlDocData localPath "9x9/xmlNamespace05.xml"
subdata = xmlSubData localPath "9x9/xmlNamespace05.xml"
lexent  = xmlLexEntity testPosn "abc &def; ghi %jkl; mno"

--------------------------------------------------------------------------------
--
--  Copyright (c) 2004, G. KLYNE.  All rights reserved.
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library 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
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this library; if not, write to:
--    The Free Software Foundation, Inc.,
--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--  or view the web page at:
--    http://www.gnu.org/copyleft/lesser.html
--
--------------------------------------------------------------------------------
-- $Source: /file/cvsdev/HaskellUtils/HaXml-1.12/test/TestXml.hs,v $
-- $Author: graham $
-- $Revision: 1.35 $
-- $Log: TestXml.hs,v $
-- Revision 1.35  2004/07/13 17:32:29  graham
-- Add xml:lang processing filter test cases.  Fix some old test cases.
--
-- Revision 1.34  2004/07/12 22:20:09  graham
-- New XML parser test cases.
--
-- Revision 1.33  2004/07/06 21:09:28  graham
-- Add specific Show instances for Namespace and QName.
--
-- Revision 1.32  2004/06/28 20:20:21  graham
-- Added new test cases for recursive substutition detection, and
-- document reformatting after
-- namespace processing.
--
-- Revision 1.31  2004/06/28 20:15:54  graham
-- Reorganized general entity substitution logic to separate traversal from
-- substitution, reprocessing and recursive reprocessing logic.
-- Added detection of recursive entity substitution.
--
-- Revision 1.30  2004/06/24 17:48:36  graham
-- Include document filename/URI in parsed document prolog,
-- for subsequent use as a base URI.
--
-- Revision 1.29  2004/06/24 14:06:57  graham
-- Rearranged various lexing functions to be slightly less obscure in their usage.
-- Factored out common code from entity value and attribute value parsing as
-- a new function 'parseString'.
--
-- Revision 1.28  2004/06/22 14:38:53  graham
-- Basic namespace processing is working.
-- Some problems with attribute handling/normalization still to be fixed.
--
-- Revision 1.27  2004/06/18 15:27:46  graham
-- Validation test suote added.  Minor validation bug fixed.  All tests pass.
--
-- Revision 1.26  2004/06/17 17:20:37  graham
-- Substitution of external general entities tested.
--
-- Revision 1.25  2004/06/17 17:08:38  graham
-- Refactored SubstitutePE.hs into SubstitutePE.hs and EntityHelpers.hs,
-- so common functions can be shared between PE and GE substitution code.
--
-- Revision 1.24  2004/06/17 15:11:35  graham
-- Pass test cases for general entity substitution in attribute values.
--
-- Revision 1.23  2004/06/17 11:40:43  graham
-- Internal general entity substitution now passes all test cases.
--
-- Revision 1.22  2004/06/16 18:17:15  graham
-- Parameter entity and lexical phases re-worked to better support
-- general entity substitution.
-- Passes all but two tricky GE substitution
-- regression tests.
--
-- Revision 1.21  2004/06/15 20:01:39  graham
-- First steps of internal general entity substitution filter are working.
-- Some of the parsing has been re-worked to support this.
-- All regression tests still pass.
--
-- Revision 1.20  2004/06/09 10:30:26  graham
-- HTTP access to external entity tested.
--
-- Revision 1.19  2004/06/08 21:21:59  graham
-- Fixed up grammar for 'contentspec'.  Another test case passes.
--
-- Revision 1.18  2004/06/08 20:20:11  graham
-- Relative filename handling for external entitities now works.
-- URI handling and HTTP access is coded, not fully tested.
--
-- Revision 1.17  2004/06/08 11:35:59  graham
-- External parameter entity substitution test passes.
--
-- Revision 1.16  2004/06/08 11:00:06  graham
-- Internal subset PE tests all pass.
-- NOTE changes from previous test cases:
-- PE definitions are stripped out by PE substitution processing,
-- Ill-formed content in unused PEs is not detected.
--
-- Revision 1.15  2004/06/08 10:42:50  graham
-- Parameter entity definition body submitted to full reLex when defined.
--
-- Revision 1.14  2004/06/07 16:42:28  graham
-- Substitution logic now compiles, but not yet built into PE handling code.
-- Two non-well-formed test cases now fail.
-- Not yet decided if they're important enough to fix.
--
-- Revision 1.13  2004/06/03 14:55:37  graham
-- Re-arrange parameter entity handling to distinguish internal subset usage
-- in the syntax, and to leave parameter entities un-substituted in the parse
-- tree.  Test case testXmlFormat21 changes as a result.
--
-- Revision 1.12  2004/06/03 12:52:21  graham
-- First stage of parameter entity re-work:
-- limit recognition of PEs to designated places in syntax.
--
-- Revision 1.11  2004/06/03 10:44:55  graham
-- Modified Unicode module to return a null character when an invalid or
-- out-of-range UTF-8 sequence is encountered.
--
-- Revision 1.10  2004/06/02 19:34:18  graham
-- Various small XML conformance improvements.
--
-- Revision 1.9  2004/06/02 15:14:37  graham
-- Restricted characters allowed in public identifier literal
--
-- Revision 1.8  2004/06/02 13:49:18  graham
-- Fixed Lex.hs to reject illegal XML characters.  This also fixes some
-- run-time failures occurring when documents containing
-- formfeed
-- characters are presented.
--
-- Revision 1.7  2004/06/02 11:00:43  graham
-- Fixed up some comments and code layout.
--
-- Revision 1.6  2004/06/02 08:39:05  graham
-- Re-worked handling of attribute values so that entitry references
-- can be recognized.
--
-- Revision 1.5  2004/05/28 15:28:16  graham
-- Improved conformance with XML, per conformance tests.
-- All but one of the xmltext/valid/sa tests now pass.
-- There are still several xmltext/not-wf/sa tests that are not detected as
-- incorrect XML, notably problems with attribute value handling.
--
-- Revision 1.4  2004/05/28 10:47:48  graham
-- Changed test harness to report error diagnostics on failure (foir debugging).
-- Fixed lexing problem for names beginning with ':' and '_'.
-- Two additional test cases (012,013) passed.
--
-- Revision 1.3  2004/05/25 21:29:48  graham
-- Refactored parser diagnostics handling.
-- Added new type classes to isolate token details.
-- All previous conformance tests still passed.
--
-- Revision 1.2  2004/05/24 12:42:37  graham
-- Create new module ExtEntity to isolate acess to external entity data.
-- Updated parse module to use this.  All tests passed.
--
-- Revision 1.1  2004/05/24 11:54:03  graham
-- Add HaXml 1.12 to local CVS repository, prior to refactoring.
-- Added CVS tags to source files to help track changes.
--