Refactor HTML test suite boilerplate to external package.

1 files changed, 49 insertions, 0 deletions

diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
new file mode 100644
index 00000000..35f5910a
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+
+module Test.Haddock.Xhtml where
+
+
+import Control.Monad
+
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+
+import Text.XML.Light
+
+
+deriving instance Eq Content
+deriving instance Eq Element
+deriving instance Eq CData
+
+
+readXml :: FilePath -> IO (Maybe Element)
+readXml = liftM parseXMLDoc . readFile
+
+
+strip :: Element -> Element
+strip = stripFooter . stripLinks
+
+
+stripLinks :: Element -> Element
+stripLinks =
+    everywhere (mkT unlink)
+  where
+    unlink attr@(Attr { attrKey = key })
+        | qName key == "href" = attr { attrVal = "#" }
+        | otherwise = attr
+
+
+stripFooter :: Element -> Element
+stripFooter =
+    everywhere (mkT defoot)
+  where
+    defoot elem
+        | isFooter elem = elem { elContent = [] }
+        | otherwise = elem
+    isFooter elem = any isFooterAttr $ elAttribs elem
+    isFooterAttr (Attr { .. }) = and
+        [ qName attrKey == "id"
+        , attrVal == "footer"
+        ]