diff options
| -rwxr-xr-x | html-test/run.hs | 72 |
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 |