TreeConstruction.hs

module Test.Mangrove.Html5Lib.TreeConstruction
    ( tests
    ) where


import qualified Control.Exception as E

import qualified Test.HUnit as U

import Web.Mangrove.Parse.Tree

import Test.Mangrove.Html5Lib.TreeConstruction.Parser

import Test.HUnit ( (@=?) )


tests :: IO U.Test
tests = U.TestLabel "tree-construction" . U.TestList <$> mapM runTestFile files
  where files =
            [ "tests" ++ show (i :: Word)
            | i <- [1..12]
                -- "tests13" doesn't exist
                ++ [14..26]
            ] ++
            [ "adoption01"
            , "adoption02"
            , "blocks"
            , "comments01"
            , "doctype01"
            , "domjs-unsafe"
            , "entities01"
            , "entities02"
            , "foreign-fragment"
            , "html5test-com"
            , "inbody01"
            , "isindex"
            , "main-element"
            , "math"
            , "menuitem-element"
            , "namespace-sensitivity"
            , "plain-text-unsafe"
            , "ruby"
            , "scriptdata01"
            , "tables01"
            , "template"
            , "tests_innerHTML_1"
            , "tricky01"
            , "webkit01"
            , "webkit02"
            ]

runTestFile :: FilePath -> IO U.Test
runTestFile p = U.TestLabel (p ++ ".dat") . U.TestList . map run <$> parseTestFile p


run :: TreeTest -> U.Test
run t = U.TestCase $ do
    result <- E.tryJust filterErrors . E.evaluate .
        uncurry finalizeTree . tree (state t) $ input t
    either return (output t @=?) $ normalizeOutput <$> result
  where filterErrors (E.ErrorCall "Adoption agency not yet implemented") = Just ()
        filterErrors (E.ErrorCall "Foster parenting not yet implemented") = Just ()
        filterErrors _ = Nothing
        normalizeOutput n = n
            { node = normalizeQuirks $ node n
            }
        normalizeQuirks (Document _) = Document NoQuirks
        normalizeQuirks n = n