aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xhtml-test/run.hs72
1 files changed, 19 insertions, 53 deletions
diff --git a/html-test/run.hs b/html-test/run.hs
index 06f20ee6..afd60a13 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -268,7 +268,11 @@ readXml = liftM Xml.parseXMLDoc . readFile
strip :: Xml.Element -> Xml.Element
-strip =
+strip = stripFooter . stripLinks
+
+
+stripLinks :: Xml.Element -> Xml.Element
+stripLinks =
everywhere (mkT unlink)
where
unlink attr@(Xml.Attr { attrKey = key })
@@ -276,6 +280,20 @@ strip =
| otherwise = attr
+stripFooter :: Xml.Element -> Xml.Element
+stripFooter =
+ everywhere (mkT defoot)
+ where
+ defoot elem
+ | isFooter elem = elem { Xml.elContent = [] }
+ | otherwise = elem
+ isFooter elem = any isFooterAttr $ Xml.elAttribs elem
+ isFooterAttr (Xml.Attr { .. }) = and
+ [ Xml.qName attrKey == "id"
+ , attrVal == "footer"
+ ]
+
+
data Flag
= FlagHaddockPath FilePath
| FlagGhcPath FilePath
@@ -371,55 +389,3 @@ mlast = listToMaybe . reverse
-- | List of modules in which we don't 'stripLinks'
preserveLinksModules :: [String]
preserveLinksModules = ["Bug253"]
-
-
--- | A rather nasty way to drop the Haddock version string from the
--- end of the generated HTML files so that we don't have to change
--- every single test every time we change versions. We rely on the the
--- last paragraph of the document to be the version. We end up with
--- malformed HTML but we don't care as we never look at it ourselves.
-dropVersion :: String -> String
-dropVersion = reverse . dropTillP . reverse
- where
- dropTillP [] = []
- dropTillP ('p':'<':xs) = xs
- dropTillP (_:xs) = dropTillP xs
-
-
-haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool
-haddockEq (fn1, file1) (fn2, file2) =
- maybeStripLinks fn1 (dropVersion file1)
- == maybeStripLinks fn2 (dropVersion file2)
-
-
-maybeStripLinks :: FilePath -- ^ Module we're considering for stripping
- -> String -> String
-maybeStripLinks file
- | takeBaseName file `elem` preserveLinksModules = id
- | otherwise = stripLinks
-
-
-stripLinks :: String -> String
-stripLinks str =
- let prefix = "<a href=\"" in
- case stripPrefix prefix str of
- Just str' -> case dropWhile (/= '>') (dropWhile (/= '"') str') of
- [] -> []
- x:xs -> stripLinks (stripHrefEnd xs)
- Nothing ->
- case str of
- [] -> []
- x : xs -> x : stripLinks xs
-
-
-stripHrefEnd :: String -> String
-stripHrefEnd s =
- let pref = "</a" in
- case stripPrefix pref s of
- Just str' -> case dropWhile (/= '>') str' of
- [] -> []
- x:xs -> xs
- Nothing ->
- case s of
- [] -> []
- x : xs -> x : stripHrefEnd xs