From ed16d303a24ef58ec764cc5d986ccc91f550053b Mon Sep 17 00:00:00 2001
From: Zubin Duggal <zubin.duggal@gmail.com>
Date: Mon, 14 Oct 2024 14:20:02 +0530
Subject: [PATCH] testsuite/haddock: strip version identifiers and unit hashes
from html tests
(cherry picked from commit fbf0889eadc410d43dd5c1657e320634b6738fa5)
---
.../haddock-test/src/Test/Haddock/Xhtml.hs | 18 +++++++++++++++++-
utils/haddock/html-test/Main.hs | 2 +-
utils/haddock/html-test/ref/Bug1004.html | 8 ++++----
utils/haddock/html-test/ref/Bug548.html | 8 ++++----
4 files changed, 26 insertions(+), 10 deletions(-)
diff --git a/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs b/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs
index 24ac2dad969..1a105a392e5 100644
--- a/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -8,6 +8,7 @@ module Test.Haddock.Xhtml
, stripIdsWhen
, stripFooter
, fixAttrValueWhen
+ , stripVersions
) where
{-
@@ -22,7 +23,7 @@ and since the `xhtml` library already handles the pretty-printing aspect,
this would appear to be a reasonable compromise for now.
-}
-import Data.Char (isSpace)
+import Data.Char (isSpace, isAlphaNum)
import Data.List (isPrefixOf, stripPrefix)
-- | Simple wrapper around the pretty-printed HTML source
@@ -142,3 +143,18 @@ stripFooter (Xml body) = Xml (findDiv body)
Just valRest''
| otherwise =
dropToDiv cs
+
+-- | Strip strings of the form <pkg>-<version>-<hash>
+-- to just <pkg>
+stripVersions :: [String] -> Xml -> Xml
+stripVersions xs (Xml body) = Xml $ foldr id body $ map go xs
+ where
+ go pkg "" = ""
+ go pkg body@(x:body') = case stripPrefix pkg body of
+ Just ('-':rest)
+ | (version,'-':rest') <- span (/= '-') rest
+ , all (`elem` ('.':['0'..'9'])) version
+ , let (hash, rest'') = span isAlphaNum rest'
+ -> pkg ++ go pkg rest''
+ _ -> x:go pkg body'
+
diff --git a/utils/haddock/html-test/Main.hs b/utils/haddock/html-test/Main.hs
index 9262c0f3b9d..732d19bc77a 100755
--- a/utils/haddock/html-test/Main.hs
+++ b/utils/haddock/html-test/Main.hs
@@ -42,7 +42,7 @@ main = do
stripIfRequired :: String -> Xml -> Xml
stripIfRequired mdl =
- stripLinks' . stripFooter
+ stripLinks' . stripFooter . stripVersions ["base"]
where
stripLinks'
| mdl `elem` preserveLinksModules = id
diff --git a/utils/haddock/html-test/ref/Bug1004.html b/utils/haddock/html-test/ref/Bug1004.html
index 5d75ef84f3f..819aa551991 100644
--- a/utils/haddock/html-test/ref/Bug1004.html
+++ b/utils/haddock/html-test/ref/Bug1004.html
@@ -210,7 +210,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -2037,7 +2037,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -2510,7 +2510,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -2604,7 +2604,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
diff --git a/utils/haddock/html-test/ref/Bug548.html b/utils/haddock/html-test/ref/Bug548.html
index 5dc51aa8a7f..5102d972119 100644
--- a/utils/haddock/html-test/ref/Bug548.html
+++ b/utils/haddock/html-test/ref/Bug548.html
@@ -186,7 +186,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -792,7 +792,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -903,7 +903,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -973,7 +973,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
--
GitLab