Tue Nov 28 11:37:53 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T14529,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13,wip/ttg6-unrevert-2017-11-22
Link       : http://git.haskell.org/haddock.git/commitdiff/6f86719bbda5339f0986dea5c26aa895e9d3069b

>---------------------------------------------------------------

commit 6f86719bbda5339f0986dea5c26aa895e9d3069b
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Wed Aug 5 18:24:56 2015 +0200

    Implement footer-stripping logic.


>---------------------------------------------------------------

6f86719bbda5339f0986dea5c26aa895e9d3069b
 html-test/run.hs | 72 +++++++++++++++-----------------------------------------
 1 file changed, 19 insertions(+), 53 deletions(-)

diff --git a/html-test/run.hs b/html-test/run.hs
index 06f20ee..afd60a1 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

