Tue Nov 28 11:37:04 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/5cf07eb5041a7947400713f9f1105cc1ebfc6eb6

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

commit 5cf07eb5041a7947400713f9f1105cc1ebfc6eb6
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Tue Aug 4 18:06:19 2015 +0200

    Incorporate old, ugly functions for comparing output files.


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

5cf07eb5041a7947400713f9f1105cc1ebfc6eb6
 html-test/run.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 61 insertions(+), 3 deletions(-)

diff --git a/html-test/run.hs b/html-test/run.hs
index ace3c6a..b9e1cc5 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -6,6 +6,7 @@
 import Control.Monad
 
 import Data.Maybe
+import Data.List
 
 import Distribution.InstalledPackageInfo
 import Distribution.Package
@@ -140,7 +141,7 @@ checkFile file = do
     then do
         out <- readFile outFile
         ref <- readFile refFile
-        return $ if haddockEq out ref
+        return $ if haddockEq (outFile, out) (refFile, ref)
             then Pass
             else Fail
     else return NoRef
@@ -285,5 +286,62 @@ mlast :: [a] -> Maybe a
 mlast = listToMaybe . reverse
 
 
-haddockEq :: String -> String -> Bool
-haddockEq _ _ = True -- TODO.
+-- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
+-- These are considered bad and should be replaced as soon as possible.
+
+
+-- | 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

